Theory List_Misc

section‹Miscellaneous List Lemmas›
theory List_Misc
imports Main
begin

lemma list_app_singletonE:
  assumes "rs1 @ rs2 = [x]"
  obtains (first) "rs1 = [x]" "rs2 = []"
        | (second) "rs1 = []" "rs2 = [x]"
using assms
by (cases "rs1") auto

lemma list_app_eq_cases:
  assumes "xs1 @ xs2 = ys1 @ ys2"
  obtains (longer)  "xs1 = take (length xs1) ys1" "xs2 = drop (length xs1) ys1 @ ys2"
        | (shorter) "ys1 = take (length ys1) xs1" "ys2 = drop (length ys1) xs1 @ xs2"
using assms by (cases "length xs1  length ys1") (metis append_eq_append_conv_if)+

lemma empty_concat: "concat (map (λx. []) ms) = []" by simp
end

Theory Negation_Type

section‹Negation Type›
theory Negation_Type
imports Main
begin

text‹Store some @{typ 'a} and remember symbolically whether you mean just @{term a} or @{term "¬ a"}.›

text‹Only negated or non-negated literals›
datatype 'a negation_type = Pos 'a | Neg 'a

fun getPos :: "'a negation_type list  'a list" where
  "getPos [] = []" |
  "getPos ((Pos x)#xs) = x#(getPos xs)" |
  "getPos (_#xs) = getPos xs"

fun getNeg :: "'a negation_type list  'a list" where
  "getNeg [] = []" |
  "getNeg ((Neg x)#xs) = x#(getNeg xs)" |
  "getNeg (_#xs) = getNeg xs"


lemma getPos_append: "getPos (as@bs) = getPos as @ getPos bs"
  by(induct as rule: getPos.induct) simp+

lemma getNeg_append: "getNeg (as@bs) = getNeg as @ getNeg bs"
  by(induct as rule: getNeg.induct) simp+

text‹If there is @{typ "'a negation_type"}, then apply a @{term map} only to @{typ 'a}.
I.e. keep @{term Neg} and @{term Pos}
fun NegPos_map :: "('a  'b)  'a negation_type list  'b negation_type list" where
  "NegPos_map _ [] = []" |
  "NegPos_map f ((Pos a)#as) = (Pos (f a))#NegPos_map f as" |
  "NegPos_map f ((Neg a)#as) = (Neg (f a))#NegPos_map f as"

text‹Example›
lemma "NegPos_map (λx::nat. x+1) [Pos 0, Neg 1] = [Pos 1, Neg 2]" by eval

lemma getPos_NegPos_map_simp: "(getPos (NegPos_map X (map Pos src))) = map X src"
  by(induction src) (simp_all)
lemma getNeg_NegPos_map_simp: "(getNeg (NegPos_map X (map Neg src))) = map X src"
  by(induction src) (simp_all)
lemma getNeg_Pos_empty: "(getNeg (NegPos_map X (map Pos src))) = []"
  by(induction src) (simp_all)
lemma getNeg_Neg_empty: "(getPos (NegPos_map X (map Neg src))) = []"
  by(induction src) (simp_all)
lemma getPos_NegPos_map_simp2: "(getPos (NegPos_map X src)) = map X (getPos src)"
  by(induction src rule: getPos.induct) (simp_all)
lemma getNeg_NegPos_map_simp2: "(getNeg (NegPos_map X src)) = map X (getNeg src)"
  by(induction src rule: getPos.induct) (simp_all)
lemma getPos_id: "getPos (map Pos xs) = xs"
  by(induction xs) (simp_all)
lemma getNeg_id: "getNeg (map Neg xs) = xs"
  by(induction xs) (simp_all)
lemma getPos_empty2: "(getPos (map Neg src)) = []"
  by(induction src) (simp_all)
lemma getNeg_empty2: "(getNeg (map Pos src)) = []"
  by(induction src) (simp_all)

lemmas NegPos_map_simps = getPos_NegPos_map_simp getNeg_NegPos_map_simp getNeg_Pos_empty getNeg_Neg_empty getPos_NegPos_map_simp2 
                          getNeg_NegPos_map_simp2 getPos_id getNeg_id getPos_empty2 getNeg_empty2
                          
lemma NegPos_map_map_Neg: "NegPos_map C (map Neg as) = map Neg (map C as)"
  by(induction as) (simp_all)
lemma NegPos_map_map_Pos: "NegPos_map C (map Pos as) = map Pos (map C as)"
  by(induction as) (simp_all)

lemma NegPos_map_append: "NegPos_map C (as @ bs) = NegPos_map C as @ NegPos_map C bs"
  by(induction as rule: getNeg.induct) (simp_all)

lemma getPos_set: "Pos a  set x  a  set (getPos x)"
 apply(induction x rule: getPos.induct)
 apply(auto)
 done
lemma getNeg_set: "Neg a  set x  a  set (getNeg x)"
 apply(induction x rule: getPos.induct)
 apply(auto)
 done
lemma getPosgetNeg_subset: "set x  set x'   set (getPos x)  set (getPos x')  set (getNeg x)  set (getNeg x')"
  apply(induction x rule: getPos.induct)
  apply(simp)
  apply(simp add: getPos_set)
  apply(rule iffI)
  apply(simp_all add: getPos_set getNeg_set)
done
lemma set_Pos_getPos_subset: "Pos ` set (getPos x)  set x"
 apply(induction x rule: getPos.induct)
 apply(simp_all)
 apply blast+
done
lemma set_Neg_getNeg_subset: "Neg ` set (getNeg x)  set x"
 apply(induction x rule: getNeg.induct)
 apply(simp_all)
 apply blast+
done
lemmas NegPos_set = getPos_set getNeg_set getPosgetNeg_subset set_Pos_getPos_subset set_Neg_getNeg_subset
hide_fact getPos_set getNeg_set getPosgetNeg_subset set_Pos_getPos_subset set_Neg_getNeg_subset


lemma negation_type_forall_split: "(isset Ms. case is of Pos i  P i | Neg i  Q i)  (iset (getPos Ms). P i)  (iset (getNeg Ms). Q i)"
  apply(rule)
   apply(simp split: negation_type.split_asm)
   using NegPos_set(1) NegPos_set(2) apply force
  apply(simp split: negation_type.split)
  using NegPos_set(1) NegPos_set(2) by fastforce

fun invert :: "'a negation_type  'a negation_type" where
  "invert (Pos x) = Neg x" |
  "invert (Neg x) = Pos x"

lemma invert_invert_id: "invert  invert = id"
  apply(clarsimp simp add: fun_eq_iff, rename_tac x, case_tac x)
   by simp+

end

Theory WordInterval_Lists

theory WordInterval_Lists
imports IP_Addresses.WordInterval
  Negation_Type
begin


fun l2wi_negation_type_union :: "('a::len word × 'a::len word) negation_type list  'a::len wordinterval" where
  "l2wi_negation_type_union [] = Empty_WordInterval" |
  "l2wi_negation_type_union ((Pos (s,e))#ls) = wordinterval_union (WordInterval s e) (l2wi_negation_type_union ls)" |
  "l2wi_negation_type_union ((Neg (s,e))#ls) = wordinterval_union (wordinterval_invert (WordInterval s e)) (l2wi_negation_type_union ls)"

lemma l2wi_negation_type_union: "wordinterval_to_set (l2wi_negation_type_union l) = 
                      ( (i,j)  set (getPos l). {i .. j})  ( (i,j)  set (getNeg l). - {i .. j})"
apply(simp add: l2wi)
apply(induction l rule: l2wi_negation_type_union.induct)
  apply(simp_all)
 apply fast+
done


definition l2wi_intersect :: "('a::len word × 'a::len word) list  'a::len wordinterval" where
  "l2wi_intersect = foldl (λ acc (s,e). wordinterval_intersection (WordInterval s e) acc) wordinterval_UNIV"

lemma l2wi_intersect: "wordinterval_to_set (l2wi_intersect l) = ( (i,j)  set l. {i .. j})"
  proof -
  { fix U ― ‹@{const wordinterval_UNIV} generalized›
    have "wordinterval_to_set (foldl (λacc (s, e). wordinterval_intersection (WordInterval s e) acc) U l) = (wordinterval_to_set U)  ((i, j)set l. {i..j})"
        apply(induction l arbitrary: U)
         apply(simp)
        by force
  } thus ?thesis
    unfolding l2wi_intersect_def by simp
  qed


fun l2wi_negation_type_intersect :: "('a::len word × 'a::len word) negation_type list  'a::len wordinterval" where
  "l2wi_negation_type_intersect [] = wordinterval_UNIV" |
  "l2wi_negation_type_intersect ((Pos (s,e))#ls) = wordinterval_intersection (WordInterval s e) (l2wi_negation_type_intersect ls)" |
  "l2wi_negation_type_intersect ((Neg (s,e))#ls) = wordinterval_intersection (wordinterval_invert (WordInterval s e)) (l2wi_negation_type_intersect ls)"

lemma l2wi_negation_type_intersect_alt: "wordinterval_to_set (l2wi_negation_type_intersect l) = 
                wordinterval_to_set (wordinterval_setminus (l2wi_intersect (getPos l)) (l2wi (getNeg l)))"
  apply(simp add: l2wi_intersect l2wi)
  apply(induction l rule :l2wi_negation_type_intersect.induct)
     apply(simp_all)
    apply(fast)+
  done

lemma l2wi_negation_type_intersect: "wordinterval_to_set (l2wi_negation_type_intersect l) = 
                      ( (i,j)  set (getPos l). {i .. j}) - ( (i,j)  set (getNeg l). {i .. j})"
  by(simp add: l2wi_negation_type_intersect_alt l2wi_intersect l2wi)

end

Theory Repeat_Stabilize

section‹Repeat finitely Until it Stabilizes›
theory Repeat_Stabilize
imports Main
begin

text‹Repeating something a number of times›


text‹Iterating a function at most @{term n} times (first parameter) until it stabilizes.›
fun repeat_stabilize :: "nat  ('a  'a)  'a  'a" where
  "repeat_stabilize 0 _ v = v" |
  "repeat_stabilize (Suc n) f v = (let v_new = f v in if v = v_new then v else repeat_stabilize n f v_new)"

lemma repeat_stabilize_funpow: "repeat_stabilize n f v = (f^^n) v"
  proof(induction n arbitrary: v)
  case (Suc n)
    have "f v = v  (f^^n) v = v" by(induction n) simp_all
    with Suc show ?case by(simp add: Let_def funpow_swap1)
  qed(simp)

lemma repeat_stabilize_induct: "(P m)  (m. P m  P (f m))  P (repeat_stabilize n f m)"
  apply(simp add: repeat_stabilize_funpow)
  apply(induction n)
   by(simp)+


end

Theory Firewall_Common

section‹Firewall Basic Syntax›
theory Firewall_Common
imports Main Simple_Firewall.Firewall_Common_Decision_State 
  "Common/Repeat_Stabilize"
begin

text‹
Our firewall model supports the following actions.
›
datatype action = Accept | Drop | Log | Reject | Call string | Return | Goto string | Empty | Unknown

text‹
We support the following algebra over primitives of type @{typ 'a}. 
The type parameter @{typ 'a} denotes the primitive match condition. For example, matching
on source IP address or on protocol.
We lift the primitives to an algebra. Note that we do not have an Or expression.
›
datatype 'a match_expr = Match 'a
                       | MatchNot "'a match_expr"
                       | MatchAnd "'a match_expr" "'a match_expr"
                       | MatchAny

definition MatchOr :: "'a match_expr  'a match_expr  'a match_expr" where
  "MatchOr m1 m2 = MatchNot (MatchAnd (MatchNot m1) (MatchNot m2))"

text‹A firewall rule consists of a match expression and an action.›
datatype 'a rule = Rule (get_match: "'a match_expr") (get_action: action)

lemma rules_singleton_rev_E:
  "[Rule m a] = rs1 @ rs2 
   (rs1 = [Rule m a]  rs2 = []  P m a) 
   (rs1 = []  rs2 = [Rule m a]  P m a)  P m a"
by (cases rs1) auto



section‹Basic Algorithms›
text‹These algorithms should be valid for all firewall semantics.
     The corresponding proofs follow once the semantics are defined.›


text‹The actions Log and Empty do not modify the packet processing in any way. They can be removed.›
fun rm_LogEmpty :: "'a rule list  'a rule list" where
  "rm_LogEmpty [] = []" |
  "rm_LogEmpty ((Rule _ Empty)#rs) = rm_LogEmpty rs" |
  "rm_LogEmpty ((Rule _ Log)#rs) = rm_LogEmpty rs" |
  "rm_LogEmpty (r#rs) = r # rm_LogEmpty rs"

lemma rm_LogEmpty_filter: "rm_LogEmpty rs = filter (λr. get_action r  Log  get_action r  Empty) rs"
 by(induction rs rule: rm_LogEmpty.induct) (simp_all)

lemma rm_LogEmpty_seq: "rm_LogEmpty (rs1@rs2) = rm_LogEmpty rs1 @ rm_LogEmpty rs2"
  by(simp add: rm_LogEmpty_filter)





text‹Optimize away MatchAny matches›
fun opt_MatchAny_match_expr_once :: "'a match_expr  'a match_expr" where
  "opt_MatchAny_match_expr_once MatchAny = MatchAny" |
  "opt_MatchAny_match_expr_once (Match a) = (Match a)" |
  "opt_MatchAny_match_expr_once (MatchNot (MatchNot m)) = (opt_MatchAny_match_expr_once m)" |
  "opt_MatchAny_match_expr_once (MatchNot m) = MatchNot (opt_MatchAny_match_expr_once m)" |
  "opt_MatchAny_match_expr_once (MatchAnd MatchAny MatchAny) = MatchAny" |
  "opt_MatchAny_match_expr_once (MatchAnd MatchAny m) = (opt_MatchAny_match_expr_once m)" |
  (*note: remove recursive call to opt_MatchAny_match_expr_once to make it probably faster*)
  "opt_MatchAny_match_expr_once (MatchAnd m MatchAny) = (opt_MatchAny_match_expr_once m)" |
  "opt_MatchAny_match_expr_once (MatchAnd _ (MatchNot MatchAny)) = (MatchNot MatchAny)" |
  "opt_MatchAny_match_expr_once (MatchAnd (MatchNot MatchAny) _) = (MatchNot MatchAny)" |
  "opt_MatchAny_match_expr_once (MatchAnd m1 m2) = MatchAnd (opt_MatchAny_match_expr_once m1) (opt_MatchAny_match_expr_once m2)"
(* without recursive call: need to apply multiple times until it stabelizes *)


text‹It is still a good idea to apply @{const opt_MatchAny_match_expr_once} multiple times. Example:›
lemma "MatchNot (opt_MatchAny_match_expr_once (MatchAnd MatchAny (MatchNot MatchAny))) = MatchNot (MatchNot MatchAny)" by simp
lemma "m = (MatchAnd (MatchAnd MatchAny MatchAny) (MatchAnd MatchAny MatchAny))  
  (opt_MatchAny_match_expr_once^^2) m  opt_MatchAny_match_expr_once m" by(simp add: funpow_def)

definition opt_MatchAny_match_expr :: "'a match_expr  'a match_expr" where
  "opt_MatchAny_match_expr m  repeat_stabilize 2 opt_MatchAny_match_expr_once m"



text‹Rewrite @{const Reject} actions to @{const Drop} actions.
      If we just care about the filtering decision (@{const FinalAllow} or @{const FinalDeny}), they should be equal.›
fun rw_Reject :: "'a rule list  'a rule list" where
  "rw_Reject [] = []" |
  "rw_Reject ((Rule m Reject)#rs) = (Rule m Drop)#rw_Reject rs" |
  "rw_Reject (r#rs) = r # rw_Reject rs"



text‹We call a ruleset simple iff the only actions are @{const Accept} and @{const Drop}
  definition simple_ruleset :: "'a rule list  bool" where
    "simple_ruleset rs  r  set rs. get_action r = Accept  get_action r = Drop"

  lemma simple_ruleset_tail: "simple_ruleset (r#rs)  simple_ruleset rs" by (simp add: simple_ruleset_def)

  lemma simple_ruleset_append: "simple_ruleset (rs1 @ rs2)  simple_ruleset rs1  simple_ruleset rs2"
    by(simp add: simple_ruleset_def, blast)







text‹Structural properties about match expressions›
  fun has_primitive :: "'a match_expr  bool" where
    "has_primitive MatchAny = False" |
    "has_primitive (Match a) = True" |
    "has_primitive (MatchNot m) = has_primitive m" |
    "has_primitive (MatchAnd m1 m2) = (has_primitive m1  has_primitive m2)"

  text‹Is a match expression equal to the @{const MatchAny} expression?
        Only applicable if no primitives are in the expression.›
  fun matcheq_matchAny :: "'a match_expr  bool" where
    "matcheq_matchAny MatchAny  True" |
    "matcheq_matchAny (MatchNot m)  ¬ (matcheq_matchAny m)" |
    "matcheq_matchAny (MatchAnd m1 m2)  matcheq_matchAny m1  matcheq_matchAny m2" |
    "matcheq_matchAny (Match _) = undefined"

  fun matcheq_matchNone :: "'a match_expr  bool" where
    "matcheq_matchNone MatchAny = False" |
    "matcheq_matchNone (Match _) = False" |
    "matcheq_matchNone (MatchNot MatchAny) = True" |
    "matcheq_matchNone (MatchNot (Match _)) = False" |
    "matcheq_matchNone (MatchNot (MatchNot m)) = matcheq_matchNone m" |
    "matcheq_matchNone (MatchNot (MatchAnd m1 m2))  matcheq_matchNone (MatchNot m1)  matcheq_matchNone (MatchNot m2)" |
    "matcheq_matchNone (MatchAnd m1 m2)   matcheq_matchNone m1  matcheq_matchNone m2"
  
  lemma matachAny_matchNone: "¬ has_primitive m  matcheq_matchAny m  ¬ matcheq_matchNone m"
    by(induction m rule: matcheq_matchNone.induct)(simp_all)
  
  lemma matcheq_matchNone_no_primitive: "¬ has_primitive m  matcheq_matchNone (MatchNot m)  ¬ matcheq_matchNone m"
    by(induction m rule: matcheq_matchNone.induct) (simp_all)






text‹optimizing match expressions›

fun optimize_matches_option :: "('a match_expr  'a match_expr option)  'a rule list  'a rule list" where
  "optimize_matches_option _ [] = []" |
  "optimize_matches_option f (Rule m a#rs) = (case f m of None  optimize_matches_option f rs | Some m  (Rule m a)#optimize_matches_option f rs)"

lemma optimize_matches_option_simple_ruleset: "simple_ruleset rs  simple_ruleset (optimize_matches_option f rs)"
  proof(induction rs rule:optimize_matches_option.induct)
  qed(simp_all add: simple_ruleset_def split: option.split)

lemma optimize_matches_option_preserves:
  "( r m. r  set rs  f (get_match r) = Some m  P m) 
     r  set (optimize_matches_option f rs). P (get_match r)"
  apply(induction rs rule: optimize_matches_option.induct)
   apply(simp; fail)
  apply(simp split: option.split)
  by fastforce
(*
lemma optimize_matches_option_preserves':
  "∀ m ∈ set rs. P (get_match m) ⟹ ∀m. P m ⟶ (∀m'. f m = Some m' ⟶ P m') ⟹ ∀m ∈ set (optimize_matches_option f rs). P (get_match m)"
  using optimize_matches_option_preserves[simplified] by metis
*)
lemma optimize_matches_option_append: "optimize_matches_option f (rs1@rs2) = optimize_matches_option f rs1 @ optimize_matches_option f rs2"
  proof(induction rs1 rule: optimize_matches_option.induct)
  qed(simp_all split: option.split)



definition optimize_matches :: "('a match_expr  'a match_expr)  'a rule list  'a rule list" where
  "optimize_matches f rs =  optimize_matches_option (λm. (if matcheq_matchNone (f m) then None else Some (f m))) rs"

lemma optimize_matches_append: "optimize_matches f (rs1@rs2) = optimize_matches f rs1 @ optimize_matches f rs2"
  by(simp add: optimize_matches_def optimize_matches_option_append)

(*Warning: simplifier loops with this lemma*)
lemma optimize_matches_fst: "optimize_matches f (r#rs) = optimize_matches f [r]@optimize_matches f rs"
by(cases r)(simp add: optimize_matches_def)

lemma optimize_matches_preserves: "( r. r  set rs  P (f (get_match r))) 
     r  set (optimize_matches f rs). P (get_match r)"
  unfolding optimize_matches_def
  apply(rule optimize_matches_option_preserves)
  by(auto split: if_split_asm)

lemma optimize_matches_simple_ruleset: "simple_ruleset rs  simple_ruleset (optimize_matches f rs)"
  by(simp add: optimize_matches_def optimize_matches_option_simple_ruleset)


definition optimize_matches_a :: "(action  'a match_expr  'a match_expr)  'a rule list  'a rule list" where
  "optimize_matches_a f rs = map (λr. Rule (f (get_action r) (get_match r)) (get_action r)) rs"

lemma optimize_matches_a_simple_ruleset: "simple_ruleset rs  simple_ruleset (optimize_matches_a f rs)"
  by(simp add: optimize_matches_a_def simple_ruleset_def)

lemma optimize_matches_a_simple_ruleset_eq:
  "simple_ruleset rs  ( m a. a = Accept  a = Drop  f1 a m = f2 a m)  optimize_matches_a f1 rs = optimize_matches_a f2 rs"
apply(induction rs)
 apply(simp add: optimize_matches_a_def)
apply(simp add: optimize_matches_a_def)
apply(simp add: simple_ruleset_def)
done

lemma optimize_matches_a_preserves: "( r. r  set rs  P (f (get_action r) (get_match r)))
      r  set (optimize_matches_a f rs). P (get_match r)"
  by(induction rs)(simp_all add: optimize_matches_a_def)



end

Theory Semantics

theory Semantics
imports Main Firewall_Common "Common/List_Misc" "HOL-Library.LaTeXsugar"
begin

section‹Big Step Semantics›


text‹
The assumption we apply in general is that the firewall does not alter any packets.
›

text‹A firewall ruleset is a map of chain names
  (e.g., INPUT, OUTPUT, FORWARD, arbitrary-user-defined-chain) to a list of rules.
  The list of rules is processed sequentially.›
type_synonym 'a ruleset = "string  'a rule list"

text‹A matcher (parameterized by the type of primitive @{typ 'a} and packet @{typ 'p})
     is a function which just tells whether a given primitive and packet matches.›
type_synonym ('a, 'p) matcher = "'a  'p  bool"

text‹Example: Assume a network packet only has a destination street number
    (for simplicity, of type @{typ "nat"}) and we only support the following match expression:
    Is the packet's street number within a certain range?
    The type for the primitive could then be @{typ "nat × nat"} and a possible implementation
    for @{typ "(nat × nat, nat) matcher"} could be
    @{term "match_street_number (a,b) p  p  {a .. b}"}.
    Usually, the primitives are a datatype which supports interfaces, IP addresses, protocols,
    ports, payload, ...›


text‹Given an @{typ "('a, 'p) matcher"} and a match expression, does a packet of type @{typ 'p}
     match the match expression?›
fun matches :: "('a, 'p) matcher  'a match_expr  'p  bool" where
"matches γ (MatchAnd e1 e2) p  matches γ e1 p  matches γ e2 p" |
"matches γ (MatchNot me) p  ¬ matches γ me p" |
"matches γ (Match e) p  γ e p" |
"matches _ MatchAny _  True"


(*Note: "matches γ (MatchNot me) p ⟷ ¬ matches γ me p" does not work for ternary logic.
  Here, we have Boolean logic and everything is fine.*)


inductive iptables_bigstep :: "'a ruleset  ('a, 'p) matcher  'p  'a rule list  state  state  bool"
  ("_,_,_ _, _  _"  [60,60,60,20,98,98] 89)
  for Γ and γ and p where
skip:    "Γ,γ,p [], t  t" |
accept:  "matches γ m p  Γ,γ,p [Rule m Accept], Undecided  Decision FinalAllow" |
drop:    "matches γ m p  Γ,γ,p [Rule m Drop], Undecided  Decision FinalDeny" |
reject:  "matches γ m p   Γ,γ,p [Rule m Reject], Undecided  Decision FinalDeny" |
log:     "matches γ m p  Γ,γ,p [Rule m Log], Undecided  Undecided" |
(*empty does not do anything to the packet. It could update the internal firewall state, e.g. marking a packet for later-on rate limiting*)
empty:   "matches γ m p  Γ,γ,p [Rule m Empty], Undecided  Undecided" |
nomatch: "¬ matches γ m p  Γ,γ,p [Rule m a], Undecided  Undecided" |
decision: "Γ,γ,p rs, Decision X  Decision X" |
seq:      "Γ,γ,p rs1, Undecided  t; Γ,γ,p rs2, t  t'  Γ,γ,p rs1@rs2, Undecided  t'" |
call_return:  " matches γ m p; Γ chain = Some (rs1@[Rule m' Return]@rs2);
                 matches γ m' p; Γ,γ,p rs1, Undecided  Undecided  
               Γ,γ,p [Rule m (Call chain)], Undecided  Undecided" |
call_result:  " matches γ m p; Γ chain = Some rs; Γ,γ,p rs, Undecided  t  
               Γ,γ,p [Rule m (Call chain)], Undecided  t"

text‹
The semantic rules again in pretty format:
\begin{center}
@{thm[mode=Axiom] skip [no_vars]}\\[1ex]
@{thm[mode=Rule] accept [no_vars]}\\[1ex]
@{thm[mode=Rule] drop [no_vars]}\\[1ex]
@{thm[mode=Rule] reject [no_vars]}\\[1ex]
@{thm[mode=Rule] log [no_vars]}\\[1ex]
@{thm[mode=Rule] empty [no_vars]}\\[1ex]
@{thm[mode=Rule] nomatch [no_vars]}\\[1ex]
@{thm[mode=Rule] decision [no_vars]}\\[1ex]
@{thm[mode=Rule] seq [no_vars]} \\[1ex]
@{thm[mode=Rule] call_return [no_vars]}\\[1ex] 
@{thm[mode=Rule] call_result [no_vars]}
\end{center}
›


(*future work:
  Add abstraction function for unknown actions. At the moment, only the explicitly listed actions are supported.
  This would also require a @{text "Decision FinalUnknown"} state
  Problem: An unknown action may modify a packet.
  Assume that we have a firewall which accepts the packets A->B and rewrites the header to A->C.
  After that firewall, there is another firewall which only accepts packets for A->C.
  A can send through both firewalls.
  
  If our model says that the firewall accepts packets A->B but does not consider packet modification,
  A might not be able to pass the second firewall with this model.
  
  Luckily, our model is correct for the filtering behaviour and explicitly does not support any actions with packet modification.
  Thus, the described scenario is not a counterexample that our model is wrong but a hint for future features
  we may want to support. Luckily, we introduced the @{term "Decision state"}, which should make adding packet modification states easy.
*)

lemma deny:
  "matches γ m p  a = Drop  a = Reject  iptables_bigstep Γ γ p [Rule m a] Undecided (Decision FinalDeny)"
by (auto intro: drop reject)

lemma seq_cons:
  assumes "Γ,γ,p [r],Undecided  t" and "Γ,γ,p rs,t  t'"
  shows "Γ,γ,p r#rs, Undecided  t'"
proof -
  from assms have "Γ,γ,p [r] @ rs, Undecided  t'" by (rule seq)
  thus ?thesis by simp
qed

lemma iptables_bigstep_induct
  [case_names Skip Allow Deny Log Nomatch Decision Seq Call_return Call_result,
   induct pred: iptables_bigstep]:
  " Γ,γ,p rs,s  t;
     t. P [] t t;
     m a. matches γ m p  a = Accept  P [Rule m a] Undecided (Decision FinalAllow);
     m a. matches γ m p  a = Drop  a = Reject  P [Rule m a] Undecided (Decision FinalDeny);
     m a. matches γ m p  a = Log  a = Empty  P [Rule m a] Undecided Undecided;
     m a. ¬ matches γ m p  P [Rule m a] Undecided Undecided;
     rs X. P rs (Decision X) (Decision X);
     rs rs1 rs2 t t'. rs = rs1 @ rs2  Γ,γ,p rs1,Undecided  t  P rs1 Undecided t  Γ,γ,p rs2,t  t'  P rs2 t t'  P rs Undecided t';
     m a chain rs1 m' rs2. matches γ m p  a = Call chain  Γ chain = Some (rs1 @ [Rule m' Return] @ rs2)  matches γ m' p  Γ,γ,p rs1,Undecided  Undecided  P rs1 Undecided Undecided  P [Rule m a] Undecided Undecided;
     m a chain rs t. matches γ m p  a = Call chain  Γ chain = Some rs  Γ,γ,p rs,Undecided  t  P rs Undecided t  P [Rule m a] Undecided t  
   P rs s t"
by (induction rule: iptables_bigstep.induct) auto

lemma skipD: "Γ,γ,p r, s  t  r = []  s = t"
by (induction rule: iptables_bigstep.induct) auto

lemma decisionD: "Γ,γ,p r, s  t  s = Decision X  t = Decision X"
by (induction rule: iptables_bigstep_induct) auto

context
  notes skipD[dest] list_app_singletonE[elim]
begin

lemma acceptD: "Γ,γ,p r, s  t  r = [Rule m Accept]  matches γ m p  s = Undecided  t = Decision FinalAllow"
by (induction rule: iptables_bigstep.induct) auto

lemma dropD: "Γ,γ,p r, s  t  r = [Rule m Drop]  matches γ m p  s = Undecided  t = Decision FinalDeny"
by (induction rule: iptables_bigstep.induct) auto

lemma rejectD: "Γ,γ,p r, s  t  r = [Rule m Reject]  matches γ m p  s = Undecided  t = Decision FinalDeny"
by (induction rule: iptables_bigstep.induct) auto

lemma logD: "Γ,γ,p r, s  t  r = [Rule m Log]  matches γ m p  s = Undecided  t = Undecided"
by (induction rule: iptables_bigstep.induct) auto

lemma emptyD: "Γ,γ,p r, s  t  r = [Rule m Empty]  matches γ m p  s = Undecided  t = Undecided"
by (induction rule: iptables_bigstep.induct) auto

lemma nomatchD: "Γ,γ,p r, s  t  r = [Rule m a]  s = Undecided  ¬ matches γ m p  t = Undecided"
by (induction rule: iptables_bigstep.induct) auto

lemma callD:
  assumes "Γ,γ,p r, s  t" "r = [Rule m (Call chain)]" "s = Undecided" "matches γ m p" "Γ chain = Some rs"
  obtains "Γ,γ,p rs,s  t"
        | rs1 rs2 m' where "rs = rs1 @ Rule m' Return # rs2" "matches γ m' p" "Γ,γ,p rs1,s  Undecided" "t = Undecided"
  using assms
  proof (induction r s t arbitrary: rs rule: iptables_bigstep.induct)
    case (seq rs1)
    thus ?case by (cases rs1) auto
  qed auto

end

lemmas iptables_bigstepD = skipD acceptD dropD rejectD logD emptyD nomatchD decisionD callD

lemma seq':
  assumes "rs = rs1 @ rs2" "Γ,γ,p rs1,s  t" "Γ,γ,p rs2,t  t'"
  shows "Γ,γ,p rs,s  t'"
using assms by (cases s) (auto intro: seq decision dest: decisionD)

lemma seq'_cons: "Γ,γ,p [r],s  t  Γ,γ,p rs,t  t'  Γ,γ,p r#rs, s  t'"
by (metis decision decisionD state.exhaust seq_cons)

lemma seq_split:
  assumes "Γ,γ,p rs, s  t" "rs = rs1@rs2"
  obtains t' where "Γ,γ,p rs1,s  t'" "Γ,γ,p rs2,t'  t"
  using assms
  proof (induction rs s t arbitrary: rs1 rs2 thesis rule: iptables_bigstep_induct)
    case Allow thus ?case by (cases rs1) (auto intro: iptables_bigstep.intros)
  next
    case Deny thus ?case by (cases rs1) (auto intro: iptables_bigstep.intros)
  next
    case Log thus ?case by (cases rs1) (auto intro: iptables_bigstep.intros)
  next
    case Nomatch thus ?case by (cases rs1) (auto intro: iptables_bigstep.intros)
  next
    case (Seq rs rsa rsb t t')
    hence rs: "rsa @ rsb = rs1 @ rs2" by simp
    note List.append_eq_append_conv_if[simp]
    from rs show ?case
      proof (cases rule: list_app_eq_cases)
        case longer
        with Seq have t1: "Γ,γ,p take (length rsa) rs1, Undecided  t"
          by simp
        from Seq longer obtain t2
          where t2a: "Γ,γ,p drop (length rsa) rs1,t  t2"
            and rs2_t2: "Γ,γ,p rs2,t2  t'"
          by blast
        with t1 rs2_t2 have "Γ,γ,p take (length rsa) rs1 @ drop (length rsa) rs1,Undecided  t2"
          by (blast intro: iptables_bigstep.seq)
        with Seq rs2_t2 show ?thesis
          by simp
      next
        case shorter
        with rs have rsa': "rsa = rs1 @ take (length rsa - length rs1) rs2"
          by (metis append_eq_conv_conj length_drop)
        from shorter rs have rsb': "rsb = drop (length rsa - length rs1) rs2"
          by (metis append_eq_conv_conj length_drop)
        from Seq rsa' obtain t1
          where t1a: "Γ,γ,p rs1,Undecided  t1"
            and t1b: "Γ,γ,p take (length rsa - length rs1) rs2,t1  t"
          by blast
        from rsb' Seq.hyps have t2: "Γ,γ,p drop (length rsa - length rs1) rs2,t  t'"
          by blast
        with seq' t1b have "Γ,γ,p rs2,t1  t'"
          by fastforce
        with Seq t1a show ?thesis
          by fast
      qed
  next
    case Call_return
    hence "Γ,γ,p rs1, Undecided  Undecided" "Γ,γ,p rs2, Undecided  Undecided"
      by (case_tac [!] rs1) (auto intro: iptables_bigstep.skip iptables_bigstep.call_return)
    thus ?case by fact
  next
    case (Call_result _ _ _ _ t)
    show ?case
      proof (cases rs1)
        case Nil
        with Call_result have "Γ,γ,p rs1, Undecided  Undecided" "Γ,γ,p rs2, Undecided  t"
          by (auto intro: iptables_bigstep.intros)
        thus ?thesis by fact
      next
        case Cons
        with Call_result have "Γ,γ,p rs1, Undecided  t" "Γ,γ,p rs2, t  t"
          by (auto intro: iptables_bigstep.intros)
        thus ?thesis by fact
      qed
  qed (auto intro: iptables_bigstep.intros)

lemma seqE:
  assumes "Γ,γ,p rs1@rs2, s  t"
  obtains ti where "Γ,γ,p rs1,s  ti" "Γ,γ,p rs2,ti  t"
  using assms by (force elim: seq_split)

lemma seqE_cons:
  assumes "Γ,γ,p r#rs, s  t"
  obtains ti where "Γ,γ,p [r],s  ti" "Γ,γ,p rs,ti  t"
  using assms by (metis append_Cons append_Nil seqE)

lemma nomatch':
  assumes "r. r  set rs  ¬ matches γ (get_match r) p"
  shows "Γ,γ,p rs, s  s"
  proof(cases s)
    case Undecided
    have "rset rs. ¬ matches γ (get_match r) p  Γ,γ,p rs, Undecided  Undecided"
      proof(induction rs)
        case Nil
        thus ?case by (fast intro: skip)
      next
        case (Cons r rs)
        hence "Γ,γ,p [r], Undecided  Undecided"
          by (cases r) (auto intro: nomatch)
        with Cons show ?case
          by (fastforce intro: seq_cons)
      qed
    with assms Undecided show ?thesis by simp
  qed (blast intro: decision)


text‹there are only two cases when there can be a Return on top-level:

   the firewall is in a Decision state
   the return does not match

In both cases, it is not applied!
›
lemma no_free_return: assumes "Γ,γ,p [Rule m Return], Undecided  t" and "matches γ m p" shows "False"
  proof -
  { fix a s
    have no_free_return_hlp: "Γ,γ,p a,s  t  matches γ m p   s = Undecided  a = [Rule m Return]  False"
    proof (induction rule: iptables_bigstep.induct)
      case (seq rs1)
      thus ?case
        by (cases rs1) (auto dest: skipD)
    qed simp_all
  } with assms show ?thesis by blast
  qed


(* seq_split is elim, seq_progress is dest *)
lemma seq_progress: "Γ,γ,p rs, s  t  rs = rs1@rs2  Γ,γ,p rs1, s  t'  Γ,γ,p rs2, t'  t"
  proof(induction arbitrary: rs1 rs2 t' rule: iptables_bigstep_induct)
    case Allow
    thus ?case
      by (cases "rs1") (auto intro: iptables_bigstep.intros dest: iptables_bigstepD)
  next
    case Deny
    thus ?case
      by (cases "rs1") (auto intro: iptables_bigstep.intros dest: iptables_bigstepD)
  next
    case Log
    thus ?case
      by (cases "rs1") (auto intro: iptables_bigstep.intros dest: iptables_bigstepD)
  next
    case Nomatch
    thus ?case
      by (cases "rs1") (auto intro: iptables_bigstep.intros dest: iptables_bigstepD)
  next
    case Decision
    thus ?case
      by (cases "rs1") (auto intro: iptables_bigstep.intros dest: iptables_bigstepD)
  next
    case(Seq rs rsa rsb t t' rs1 rs2 t'')
    hence rs: "rsa @ rsb = rs1 @ rs2" by simp
    note List.append_eq_append_conv_if[simp]
    (* TODO larsrh custom case distinction rule *)

    from rs show "Γ,γ,p rs2,t''  t'"
      proof(cases rule: list_app_eq_cases)
        case longer
        have "rs1 = take (length rsa) rs1 @ drop (length rsa) rs1"
          by auto
        with Seq longer show ?thesis
          by (metis append_Nil2 skipD seq_split)
      next
        case shorter
        with Seq(7) Seq.hyps(3) Seq.IH(1) rs show ?thesis
          by (metis seq' append_eq_conv_conj)
      qed
  next
    case(Call_return m a chain rsa m' rsb)
    have xx: "Γ,γ,p [Rule m (Call chain)], Undecided  t'  matches γ m p 
          Γ chain = Some (rsa @ Rule m' Return # rsb) 
          matches γ m' p 
          Γ,γ,p rsa, Undecided  Undecided 
          t' = Undecided"
      apply(erule callD)
           apply(simp_all)
      apply(erule seqE)
      apply(erule seqE_cons)
      by (metis Call_return.IH no_free_return self_append_conv skipD)

    show ?case
      proof (cases rs1)
        case (Cons r rs)
        thus ?thesis
          using Call_return
          apply(case_tac "[Rule m a] = rs2")
           apply(simp)
          apply(simp)
          using xx by blast
      next
        case Nil
        moreover hence "t' = Undecided"
          by (metis Call_return.hyps(1) Call_return.prems(2) append.simps(1) decision no_free_return seq state.exhaust)
        moreover have "m. Γ,γ,p [Rule m a], Undecided  Undecided"
          by (metis (no_types) Call_return(2) Call_return.hyps(3) Call_return.hyps(4) Call_return.hyps(5) call_return nomatch)
        ultimately show ?thesis
          using Call_return.prems(1) by auto
      qed
  next
    case(Call_result m a chain rs t)
    thus ?case
      proof (cases rs1)
        case Cons
        thus ?thesis
          using Call_result
          apply(auto simp add: iptables_bigstep.skip iptables_bigstep.call_result dest: skipD)
          apply(drule callD, simp_all)
           apply blast
          by (metis Cons_eq_appendI append_self_conv2 no_free_return seq_split)
      qed (fastforce intro: iptables_bigstep.intros dest: skipD)
  qed (auto dest: iptables_bigstepD)


theorem iptables_bigstep_deterministic: assumes "Γ,γ,p rs, s  t" and "Γ,γ,p rs, s  t'" shows "t = t'"
proof -
  { fix r1 r2 m t
    assume a1: "Γ,γ,p r1 @ Rule m Return # r2, Undecided  t" and a2: "matches γ m p" and a3: "Γ,γ,p r1,Undecided  Undecided"
    have False
    proof -
      from a1 a3 have "Γ,γ,p Rule m Return # r2, Undecided  t"
        by (blast intro: seq_progress)
      hence "Γ,γ,p [Rule m Return] @ r2, Undecided  t"
        by simp
      from seqE[OF this] obtain ti where "Γ,γ,p [Rule m Return], Undecided  ti" by blast
      with no_free_return a2 show False by fast (*by (blast intro: no_free_return elim: seq_split)*)
    qed
  } note no_free_return_seq=this
  
  from assms show ?thesis
  proof (induction arbitrary: t' rule: iptables_bigstep_induct)
    case Seq
    thus ?case
      by (metis seq_progress)
  next
    case Call_result
    thus ?case
      by (metis no_free_return_seq callD)
  next
    case Call_return
    thus ?case
      by (metis append_Cons callD no_free_return_seq)
  qed (auto dest: iptables_bigstepD)
qed

lemma iptables_bigstep_to_undecided: "Γ,γ,p rs, s  Undecided  s = Undecided"
  by (metis decisionD state.exhaust)

lemma iptables_bigstep_to_decision: "Γ,γ,p rs, Decision Y  Decision X  Y = X"
  by (metis decisionD state.inject)

lemma Rule_UndecidedE:
  assumes "Γ,γ,p [Rule m a], Undecided  Undecided"
  obtains (nomatch) "¬ matches γ m p"
        | (log) "a = Log  a = Empty"
        | (call) c where "a = Call c" "matches γ m p"
  using assms
  proof (induction "[Rule m a]" Undecided Undecided rule: iptables_bigstep_induct)
    case Seq
    thus ?case
      by (metis append_eq_Cons_conv append_is_Nil_conv iptables_bigstep_to_undecided)
  qed simp_all

lemma Rule_DecisionE:
  assumes "Γ,γ,p [Rule m a], Undecided  Decision X"
  obtains (call) chain where "matches γ m p" "a = Call chain"
        | (accept_reject) "matches γ m p" "X = FinalAllow  a = Accept" "X = FinalDeny  a = Drop  a = Reject"
  using assms
  proof (induction "[Rule m a]" Undecided "Decision X" rule: iptables_bigstep_induct)
    case (Seq rs1)
    thus ?case
      by (cases rs1) (auto dest: skipD)
  qed simp_all


lemma log_remove:
  assumes "Γ,γ,p rs1 @ [Rule m Log] @ rs2, s  t"
  shows "Γ,γ,p rs1 @ rs2, s  t"
  proof -
    from assms obtain t' where t': "Γ,γ,p rs1, s  t'" "Γ,γ,p [Rule m Log] @ rs2, t'  t"
      by (blast elim: seqE)
    hence "Γ,γ,p Rule m Log # rs2, t'  t"
      by simp
    then obtain t'' where "Γ,γ,p [Rule m Log], t'  t''" "Γ,γ,p rs2, t''  t"
      by (blast elim: seqE_cons)
    with t' show ?thesis
      by (metis state.exhaust iptables_bigstep_deterministic decision log nomatch seq)
  qed
lemma empty_empty:
  assumes "Γ,γ,p rs1 @ [Rule m Empty] @ rs2, s  t"
  shows "Γ,γ,p rs1 @ rs2, s  t"
  proof -
    from assms obtain t' where t': "Γ,γ,p rs1, s  t'" "Γ,γ,p [Rule m Empty] @ rs2, t'  t"
      by (blast elim: seqE)
    hence "Γ,γ,p Rule m Empty # rs2, t'  t"
      by simp
    then obtain t'' where "Γ,γ,p [Rule m Empty], t'  t''" "Γ,γ,p rs2, t''  t"
      by (blast elim: seqE_cons)
    with t' show ?thesis
      by (metis state.exhaust iptables_bigstep_deterministic decision empty nomatch seq)
  qed



lemma Unknown_actions_False: "Γ,γ,p r # rs, Undecided  t  r = Rule m a  matches γ m p  a = Unknown  (chain. a = Goto chain)  False"
proof -
  have 1: "Γ,γ,p [Rule m Unknown], Undecided  t  matches γ m p  False"
  by (induction "[Rule m Unknown]" Undecided t rule: iptables_bigstep.induct)
     (auto elim: list_app_singletonE dest: skipD)
  
  { fix chain
    have "Γ,γ,p [Rule m (Goto chain)], Undecided  t  matches γ m p  False"
    by (induction "[Rule m (Goto chain)]" Undecided t rule: iptables_bigstep.induct)
       (auto elim: list_app_singletonE dest: skipD)
  }note 2=this
  show "Γ,γ,p r # rs, Undecided  t  r = Rule m a  matches γ m p  a = Unknown  (chain. a = Goto chain)  False"
  apply(erule seqE_cons)
  apply(case_tac ti)
   apply(simp_all)
   using Rule_UndecidedE apply fastforce
  by (metis "1" "2" decision iptables_bigstep_deterministic)
qed

text‹
The notation we prefer in the paper. The semantics are defined for fixed Γ› and γ›
locale iptables_bigstep_fixedbackground =
  fixes Γ::"'a ruleset"
  and γ::"('a, 'p) matcher"
  begin

  inductive iptables_bigstep' :: "'p  'a rule list  state  state  bool"
    ("_⊢'' _, _  _"  [60,20,98,98] 89)
    for p where
  skip:    "p⊢' [], t  t" |
  accept:  "matches γ m p  p⊢' [Rule m Accept], Undecided  Decision FinalAllow" |
  drop:    "matches γ m p  p⊢' [Rule m Drop], Undecided  Decision FinalDeny" |
  reject:  "matches γ m p   p⊢' [Rule m Reject], Undecided  Decision FinalDeny" |
  log:     "matches γ m p  p⊢' [Rule m Log], Undecided  Undecided" |
  empty:   "matches γ m p  p⊢' [Rule m Empty], Undecided  Undecided" |
  nomatch: "¬ matches γ m p  p⊢' [Rule m a], Undecided  Undecided" |
  decision: "p⊢' rs, Decision X  Decision X" |
  seq:      "p⊢' rs1, Undecided  t; p⊢' rs2, t  t'  p⊢' rs1@rs2, Undecided  t'" |
  call_return:  " matches γ m p; Γ chain = Some (rs1@[Rule m' Return]@rs2);
                   matches γ m' p; p⊢' rs1, Undecided  Undecided  
                 p⊢' [Rule m (Call chain)], Undecided  Undecided" |
  call_result:  " matches γ m p; p⊢' the (Γ chain), Undecided  t  
                 p⊢' [Rule m (Call chain)], Undecided  t"

  definition wf_Γ:: "'a rule list  bool" where
    "wf_Γ rs  rsg  ran Γ  {rs}. (r  set rsg.  chain. get_action r = Call chain  Γ chain  None)"

  lemma wf_Γ_append: "wf_Γ (rs1@rs2)  wf_Γ rs1  wf_Γ rs2"
    by(simp add: wf_Γ_def, blast)
  lemma wf_Γ_tail: "wf_Γ (r # rs)  wf_Γ rs" by(simp add: wf_Γ_def)
  lemma wf_Γ_Call: "wf_Γ [Rule m (Call chain)]  wf_Γ (the (Γ chain))  (rs. Γ chain = Some rs)"
    apply(simp add: wf_Γ_def)
    by (metis option.collapse ranI)
  
  lemma "wf_Γ rs  p⊢' rs, s  t  Γ,γ,p rs, s  t"
    apply(rule iffI)
     apply(rotate_tac 1)
     apply(induction rs s t rule: iptables_bigstep'.induct)
               apply(auto intro: iptables_bigstep.intros simp: wf_Γ_append dest!: wf_Γ_Call)[11]
    apply(rotate_tac 1)
    apply(induction rs s t rule: iptables_bigstep.induct)
              apply(auto intro: iptables_bigstep'.intros simp: wf_Γ_append dest!: wf_Γ_Call)[11]
    done
    
  end




text‹Showing that semantics are defined.
  For rulesets which can be loaded by the Linux kernel. The kernel does not allow loops.›




text‹
  We call a ruleset well-formed (wf) iff all @{const Call}s are into actually existing chains.
›
definition wf_chain :: "'a ruleset  'a rule list  bool" where
  "wf_chain Γ rs  (r  set rs.  chain. get_action r = Call chain  Γ chain  None)"
lemma wf_chain_append: "wf_chain Γ (rs1@rs2)  wf_chain Γ rs1  wf_chain Γ rs2"
  by(simp add: wf_chain_def, blast)

lemma wf_chain_fst: "wf_chain Γ (r # rs)   wf_chain Γ (rs)"
  by(simp add: wf_chain_def)


text‹This is what our tool will check at runtime›
definition sanity_wf_ruleset :: "(string × 'a rule list) list  bool" where
  "sanity_wf_ruleset Γ  distinct (map fst Γ) 
          ( rs  ran (map_of Γ). (r  set rs. case get_action r of Accept  True
                                                                    | Drop  True
                                                                    | Reject  True
                                                                    | Log  True
                                                                    | Empty  True
                                                                    | Call chain  chain  dom (map_of Γ)
                                                                    | Goto chain  chain  dom (map_of Γ)
                                                                    | Return  True
                                                                    | _  False))"

lemma sanity_wf_ruleset_wf_chain: "sanity_wf_ruleset Γ  rs  ran (map_of Γ)  wf_chain (map_of Γ) rs"
  apply(simp add: sanity_wf_ruleset_def wf_chain_def)
  by fastforce

lemma sanity_wf_ruleset_start: "sanity_wf_ruleset Γ  chain_name  dom (map_of Γ) 
  default_action = Accept  default_action = Drop  
  wf_chain (map_of Γ) [Rule MatchAny (Call chain_name), Rule MatchAny default_action]"
 apply(simp add: sanity_wf_ruleset_def wf_chain_def)
 apply(safe)
  apply(simp_all)
  apply blast+
 done

lemma [code]: "sanity_wf_ruleset Γ =
  (let dom = map fst Γ;
       ran = map snd Γ
   in distinct dom 
    ( rs  set ran. (r  set rs. case get_action r of Accept  True
                                                       | Drop  True
                                                       | Reject  True
                                                       | Log  True
                                                       | Empty  True
                                                       | Call chain  chain  set dom
                                                       | Goto chain  chain  set dom
                                                       | Return  True
                                                       | _  False)))"
  proof -
  have set_map_fst: "set (map fst Γ) = dom (map_of Γ)"
    by (simp add: dom_map_of_conv_image_fst)
  have set_map_snd: "distinct (map fst Γ)  set (map snd Γ) = ran (map_of Γ)"
    by (simp add: ran_distinct)
  show ?thesis
  unfolding sanity_wf_ruleset_def Let_def
  apply(subst set_map_fst)+
  apply(rule iffI)
   apply(elim conjE)
   apply(subst set_map_snd)
    apply(simp)
   apply(simp)
  apply(elim conjE)
  apply(subst(asm) set_map_snd)
   apply(simp_all)
  done
qed





lemma semantics_bigstep_defined1: assumes "rsg  ran Γ  {rs}. wf_chain Γ rsg"
  and "rsg  ran Γ  {rs}.  r  set rsg. (chain. get_action r  Goto chain)  get_action r  Unknown"
  and " r  set rs. get_action r  Return" (*no toplevel return*)
  and "(name  dom Γ. t. Γ,γ,p the (Γ name), Undecided  t)" (*defined for all chains in the background ruleset*)
  shows "t. Γ,γ,p rs, s  t"
using assms proof(induction rs)
case Nil thus ?case
 apply(rule_tac x=s in exI)
 by(simp add: skip)
next
case (Cons r rs)
  from Cons.prems Cons.IH obtain t' where t': "Γ,γ,p rs, s  t'"
    apply simp
    apply(elim conjE)
    apply(simp add: wf_chain_fst)
    by blast

  obtain m a where r: "r = Rule m a" by(cases r) blast

  show ?case
  proof(cases "matches γ m p")
  case False
    hence "Γ,γ,p [r], s  s"
      apply(cases s)
       apply(simp add: nomatch r)
      by(simp add: decision)
    thus ?thesis
      apply(rule_tac x=t' in exI)
      apply(rule_tac t=s in seq'_cons)
       apply assumption
      using t' by(simp)
  next
  case True
    show ?thesis
    proof(cases s)
    case (Decision X) thus ?thesis
      apply(rule_tac x="Decision X" in exI)
      by(simp add: decision)
    next
    case Undecided
      have "t. Γ,γ,p Rule m a # rs, Undecided  t"
      proof(cases a)
        case Accept with True show ?thesis
          apply(rule_tac x="Decision FinalAllow" in exI)
          apply(rule_tac t="Decision FinalAllow" in seq'_cons)
           by(auto intro: iptables_bigstep.intros)
        next
        case Drop with True show ?thesis
          apply(rule_tac x="Decision FinalDeny" in exI)
          apply(rule_tac t="Decision FinalDeny" in seq'_cons)
           by(auto intro: iptables_bigstep.intros)
        next
        case Log with True t' Undecided show ?thesis
          apply(rule_tac x=t' in exI)
          apply(rule_tac t=Undecided in seq'_cons)
           by(auto intro: iptables_bigstep.intros)
        next
        case Reject with True show ?thesis
          apply(rule_tac x="Decision FinalDeny" in exI)
          apply(rule_tac t="Decision FinalDeny" in seq'_cons)
           by(auto intro: iptables_bigstep.intros)[2]
        next
        case Return with Cons.prems(3)[simplified r] show ?thesis by simp
        next
        case Goto with Cons.prems(2)[simplified r] show ?thesis by auto
        next
        case (Call chain_name)
          from Call Cons.prems(1) obtain rs' where 1: "Γ chain_name = Some rs'" by(simp add: r wf_chain_def) blast
          with Cons.prems(4) obtain t'' where 2: "Γ,γ,p the (Γ chain_name), Undecided  t''" by blast
          from 1 2 True have "Γ,γ,p [Rule m (Call chain_name)], Undecided  t''" by(auto dest: call_result)
          with Call t' Undecided show ?thesis
          apply(simp add: r)
          apply(cases t'')
           apply simp
           apply(rule_tac x=t' in exI)
           apply(rule_tac t=Undecided in seq'_cons)
            apply(auto intro: iptables_bigstep.intros)[2]
          apply(simp)
          apply(rule_tac x=t'' in exI)
          apply(rule_tac t=t'' in seq'_cons)
           apply(auto intro: iptables_bigstep.intros)
         done
        next
        case Empty  with True t' Undecided show ?thesis
         apply(rule_tac x=t' in exI)
         apply(rule_tac t=Undecided in seq'_cons)
          by(auto intro: iptables_bigstep.intros)
        next
        case Unknown with Cons.prems(2)[simplified r] show ?thesis by(simp)
      qed
      thus ?thesis
      unfolding r Undecided by simp
    qed
  qed
qed

text‹Showing the main theorem›

context
begin
  private lemma iptables_bigstep_defined_if_singleton_rules:
  " r  set rs. (t. Γ,γ,p [r], s  t)  t. Γ,γ,p rs, s  t"
  proof(induction rs arbitrary: s)
  case Nil hence "Γ,γ,p [], s  s" by(simp add: skip)
     thus ?case by blast
  next
  case(Cons r rs s)
    from Cons.prems obtain t where t: "Γ,γ,p [r], s  t" by simp blast
    with Cons show ?case
    proof(cases t)
      case Decision with t show ?thesis by (meson decision seq'_cons)
      next
      case Undecided
      from Cons obtain t' where t': "Γ,γ,p rs, s  t'" by simp blast
      with Undecided t show ?thesis
      apply(rule_tac x=t' in exI)
      apply(rule seq'_cons)
       apply(simp)
      using iptables_bigstep_to_undecided by fastforce
    qed
  qed
  
  
  
  
  
  
  
  text‹well founded relation.›
  definition calls_chain :: "'a ruleset  (string × string) set" where
    "calls_chain Γ = {(r, s). case Γ r of Some rs  m. Rule m (Call s)  set rs | None  False}"  
  
  lemma calls_chain_def2: "calls_chain Γ = {(caller, callee). rs m. Γ caller = Some rs  Rule m (Call callee)  set rs}"
    unfolding calls_chain_def
    apply(safe)
     apply(simp split: option.split_asm)
    apply(simp)
    by blast
  
  text‹example›
  private lemma "calls_chain [
      ''FORWARD''  [(Rule m1 Log), (Rule m2 (Call ''foo'')), (Rule m3 Accept), (Rule m' (Call ''baz''))],
      ''foo''  [(Rule m4 Log), (Rule m5 Return), (Rule m6 (Call ''bar''))], 
      ''bar''  [],
      ''baz''  []] =
      {(''FORWARD'', ''foo''), (''FORWARD'', ''baz''), (''foo'', ''bar'')}"
    unfolding calls_chain_def by(auto split: option.split_asm if_split_asm)
  
  private lemma "wf (calls_chain [
      ''FORWARD''  [(Rule m1 Log), (Rule m2 (Call ''foo'')), (Rule m3 Accept), (Rule m' (Call ''baz''))],
      ''foo''  [(Rule m4 Log), (Rule m5 Return), (Rule m6 (Call ''bar''))], 
      ''bar''  [],
      ''baz''  []])"
  proof -
    have g: "calls_chain [''FORWARD''  [(Rule m1 Log), (Rule m2 (Call ''foo'')), (Rule m3 Accept), (Rule m' (Call ''baz''))],
            ''foo''  [(Rule m4 Log), (Rule m5 Return), (Rule m6 (Call ''bar''))], 
            ''bar''  [],
            ''baz''  []] = {(''FORWARD'', ''foo''), (''FORWARD'', ''baz''), (''foo'', ''bar'')}"
    by(auto simp add: calls_chain_def split: option.split_asm if_split_asm)
    show ?thesis
      unfolding g
      apply(simp)
      apply safe
       apply(erule rtranclE, simp_all)
      apply(erule rtranclE, simp_all)
      done
  qed    
      
  
  text‹In our proof, we will need the reverse.›
  private definition called_by_chain :: "'a ruleset  (string × string) set" where
    "called_by_chain Γ = {(callee, caller). case Γ caller of Some rs  m. Rule m (Call callee)  set rs | None  False}"
  private lemma called_by_chain_converse: "calls_chain Γ = converse (called_by_chain Γ)"
    apply(simp add: calls_chain_def called_by_chain_def)
    by blast
  private lemma wf_called_by_chain: "finite (calls_chain Γ)  wf (calls_chain Γ)  wf (called_by_chain Γ)"
    apply(frule Wellfounded.wf_acyclic)
    apply(drule(1) Wellfounded.finite_acyclic_wf_converse)
    apply(simp add: called_by_chain_converse)
    done
  
  
  private lemma helper_cases_call_subchain_defined_or_return:
        "(xran Γ. wf_chain Γ x) 
         rsgran Γ. rset rsg. (chain. get_action r  Goto chain)  get_action r  Unknown 
         y m. rset rs_called. r = Rule m (Call y)  (t. Γ,γ,p [Rule m (Call y)], Undecided  t) 
         wf_chain Γ rs_called  
         rset rs_called. (chain. get_action r  Goto chain)  get_action r  Unknown 
         (t. Γ,γ,p rs_called, Undecided  t) 
         (rs_called1 rs_called2 m'.
             rs_called = (rs_called1 @ [Rule m' Return] @ rs_called2) 
             matches γ m' p  Γ,γ,p rs_called1, Undecided  Undecided)"
  proof(induction rs_called arbitrary:)
  case Nil hence "t. Γ,γ,p [], Undecided  t"
     apply(rule_tac x=Undecided in exI)
     by(simp add: skip)
   thus ?case by simp
  next
  case (Cons r rs)
    from Cons.prems have "wf_chain Γ [r]" by(simp add: wf_chain_def)
    from Cons.prems have IH:"(t'. Γ,γ,p rs, Undecided  t') 
      (rs_called1 rs_called2 m'.
          rs = (rs_called1 @ [Rule m' Return] @ rs_called2) 
          matches γ m' p  Γ,γ,p rs_called1, Undecided  Undecided)"
      apply -
      apply(rule Cons.IH)
          apply(auto dest: wf_chain_fst)
      done
  
    from Cons.prems have case_call: "r = Rule m (Call y)  (t. Γ,γ,p [Rule m (Call y)], Undecided  t)" for y m
      by(simp)
  
    obtain m a where r: "r = Rule m a" by(cases r) simp
  
    from Cons.prems have a_not: "(chain. a  Goto chain)  a  Unknown" by(simp add: r)
  
    have ex_neq_ret: "a  Return  t. Γ,γ,p [Rule m a], Undecided  t"
    proof(cases "matches γ m p")
    case False thus ?thesis by(rule_tac x=Undecided in exI)(simp add: nomatch; fail)
    next
    case True
      assume "a  Return"
      show ?thesis
      proof(cases a)
      case Accept with True show ?thesis
        by(rule_tac x="Decision FinalAllow" in exI) (simp add: accept; fail)
      next
      case Drop with True show ?thesis
        by(rule_tac x="Decision FinalDeny" in exI) (simp add: drop; fail)
      next
      case Log with True show ?thesis
        by(rule_tac x="Undecided" in exI)(simp add: log; fail)
      next
      case Reject with True show ?thesis
        by(rule_tac x="Decision FinalDeny" in exI) (simp add: reject; fail)
      next
      case Call with True show ?thesis
        apply(simp)
        apply(rule case_call)
        apply(simp add: r; fail)
        done
      next
      case Empty with True show ?thesis by(rule_tac x="Undecided" in exI) (simp add: empty; fail)
      next
      case Return with a  Return› show ?thesis by simp
      qed(simp_all add: a_not)
    qed
  
    have *: "?case"
      if pre: "rs = rs_called1 @ Rule m' Return # rs_called2  matches γ m' p  Γ,γ,p rs_called1, Undecided  Undecided"
      for rs_called1 m' rs_called2
    proof(cases "matches γ m p")
    case False thus ?thesis
      apply -
      apply(rule disjI2)
      apply(rule_tac x="r#rs_called1" in exI)
      apply(rule_tac x=rs_called2 in exI)
      apply(rule_tac x=m' in exI)
      apply(simp add: r pre)
      apply(rule_tac t=Undecided in seq_cons)
       apply(simp add: r nomatch; fail)
      apply(simp add: pre; fail)
      done
    next
    case True
      from pre have rule_case_dijs1: "X. Γ,γ,p [Rule m a], Undecided  Decision X  ?thesis"
        apply -
        apply(rule disjI1)
        apply(elim exE conjE, rename_tac X)
        apply(simp)
        apply(rule_tac x="Decision X" in exI)
        apply(rule_tac t="Decision X" in seq_cons)
         apply(simp add: r; fail)
        apply(simp add: decision; fail)
        done

      from pre have rule_case_dijs2: "Γ,γ,p [Rule m a], Undecided  Undecided  ?thesis"
        apply -
        apply(rule disjI2)
        apply(rule_tac x="r#rs_called1" in exI)
        apply(rule_tac x=rs_called2 in exI)
        apply(rule_tac x=m' in exI)
        apply(simp add: r)
        apply(rule_tac t=Undecided in seq_cons)
         apply(simp; fail)
        apply(simp;fail)
        done

      show ?thesis
      proof(cases a)
      case Accept show ?thesis
        apply(rule rule_case_dijs1)
        apply(rule_tac x="FinalAllow" in exI)
        using True pre Accept by(simp add: accept)
      next
      case Drop show ?thesis
        apply(rule rule_case_dijs1)
        apply(rule_tac x="FinalDeny" in exI)
        using True Drop by(simp add: deny)
      next
      case Log show ?thesis
        apply(rule rule_case_dijs2)
        using Log True by(simp add: log)
      next
      case Reject show ?thesis
        apply(rule rule_case_dijs1)
        apply(rule_tac x="FinalDeny" in exI)
        using Reject True by(simp add: reject)
      next
      case (Call x5)
        have "t. Γ,γ,p [Rule m (Call x5)], Undecided  t" by(rule case_call) (simp add: r Call)
        with Call pre True show ?thesis
        apply(simp)
        apply(elim exE, rename_tac t_called)
        apply(case_tac t_called)
         apply(simp)
         apply(rule disjI2)
         apply(rule_tac x="r#rs_called1" in exI)
         apply(rule_tac x=rs_called2 in exI)
         apply(rule_tac x=m' in exI)
         apply(simp add: r)
         apply(rule_tac t=Undecided in seq_cons)
          apply(simp add: r; fail)
         apply(simp; fail)
        apply(rule disjI1)
        apply(rule_tac x=t_called in exI)
        apply(rule_tac t=t_called in seq_cons)
         apply(simp add: r; fail)
        apply(simp add: decision; fail)
        done
      next
      case Empty show ?thesis
        apply(rule rule_case_dijs2)
        using Empty True by(simp add: pre empty)
      next
      case Return show ?thesis
       apply(rule disjI2)
       apply(rule_tac x="[]" in exI)
       apply(rule_tac x="rs_called1 @ Rule m' Return # rs_called2" in exI)
       apply(rule_tac x=m in exI)
       using Return True pre by(simp add: skip r)
      qed(simp_all add: a_not)
    qed
     
    from IH have **: "a  Return  (t. Γ,γ,p [Rule m a], Undecided  t)  ?case"
    proof(elim disjE, goal_cases)
    case 2
      from this obtain rs_called1 m' rs_called2 where 
        a1: "rs = rs_called1 @ [Rule m' Return] @ rs_called2" and
        a2: "matches γ m' p" and a3: "Γ,γ,p rs_called1, Undecided  Undecided" by blast
      show ?case
        apply(rule *)
        using a1 a2 a3 by simp
    next
    case 1 thus ?case 
      proof(cases "a  Return")
      case True
        with 1 obtain t1 t2 where t1: "Γ,γ,p [Rule m a], Undecided  t1"
                              and t2: "Γ,γ,p rs, Undecided  t2" by blast
        from t1 t2 show ?thesis
        apply -
        apply(rule disjI1)
        apply(simp add: r)
        apply(cases t1)
         apply(simp_all)
         apply(rule_tac x=t2 in exI)
         apply(rule_tac seq'_cons)
          apply(simp_all)
        apply (meson decision seq_cons)
        done
      next
      case False show ?thesis
        proof(cases "matches γ m p")
          assume "¬ matches γ m p" with 1 show ?thesis
            apply -
            apply(rule disjI1)
            apply(elim exE)
            apply(rename_tac t')
            apply(rule_tac x=t' in exI)
            apply(rule_tac t=Undecided in seq_cons)
             apply(simp add: r nomatch; fail)
            by(simp)
        next
          assume "matches γ m p" with False show ?thesis
            apply -
            apply(rule disjI2)
            apply(rule_tac x="[]" in exI)
            apply(rule_tac x=rs in exI)
            apply(rule_tac x=m in exI)
            apply(simp add: r skip; fail)
            done
        qed
      qed
    qed
    thus ?case using ex_neq_ret by blast
  qed
  
  
  lemma helper_defined_single: 
    assumes "wf (called_by_chain Γ)" 
    and "rsg  ran Γ  {[Rule m a]}. wf_chain Γ rsg"
    and "rsg  ran Γ  {[Rule m a]}.  r  set rsg. (¬(chain. get_action r = Goto chain))  get_action r  Unknown"
    and "a  Return" (*no toplevel Return*)
    shows "t. Γ,γ,p [Rule m a], s  t"
  proof(cases s)
  case (Decision decision) thus ?thesis
    apply(rule_tac x="Decision decision" in exI)
    apply(simp)
    using iptables_bigstep.decision by fast
  next
  case Undecided
    have "t. Γ,γ,p [Rule m a], Undecided  t"
    proof(cases "matches γ m p")
    case False with assms show ?thesis
      apply(rule_tac x=Undecided in exI)
      apply(rule_tac t=Undecided in seq'_cons)
       apply (metis empty_iff empty_set insert_iff list.simps(15) nomatch' rule.sel(1)) 
      apply(simp add: skip; fail)
      done
    next
    case True
    show ?thesis
      proof(cases a)
      case Unknown with assms(3) show ?thesis by simp
      next
      case Goto with assms(3) show ?thesis by auto
      next
      case Accept with True show ?thesis by(auto intro: iptables_bigstep.intros)
      next
      case Drop with True show ?thesis by(auto intro: iptables_bigstep.intros)
      next
      case Reject with True show ?thesis by(auto intro: iptables_bigstep.intros)
      next
      case Log with True show ?thesis by(auto intro: iptables_bigstep.intros)
      next
      case Empty with True show ?thesis by(auto intro: iptables_bigstep.intros)
      next
      case Return with assms show ?thesis by simp
      next
      case (Call chain_name)
        thm wf_induct_rule[where r="(calls_chain Γ)" and P="λx. t. Γ,γ,p [Rule m (Call x)], Undecided  t"]
        ― ‹Only the assumptions we will need›
        from assms have "wf (called_by_chain Γ)"
            "rsgran Γ. wf_chain Γ rsg"
            "rsgran Γ. rset rsg. (chain. get_action r  Goto chain)  get_action r  Unknown" by auto
        ― ‹strengthening the IH to do a well-founded induction›
        hence "matches γ m p  wf_chain Γ [Rule m (Call chain_name)]  (t. Γ,γ,p [Rule m (Call chain_name)], Undecided  t)"
        proof(induction arbitrary: m rule: wf_induct_rule[where r="called_by_chain Γ"])
        case (less chain_name_neu)
          from less.prems have "Γ chain_name_neu  None" by(simp add: wf_chain_def)
          from this obtain rs_called where rs_called: "Γ chain_name_neu = Some rs_called" by blast
  
          from less rs_called have "wf_chain Γ rs_called" by (simp add: ranI)
          from less rs_called have "rs_called  ran Γ" by (simp add: ranI)
  
          (*get good IH*)
          from less.prems rs_called have
            "y m. r  set rs_called. r = Rule m (Call y)  (y, chain_name_neu)  called_by_chain Γ  wf_chain Γ [Rule m (Call y)]"
             apply(simp)
             apply(intro impI allI conjI)
              apply(simp add: called_by_chain_def)
              apply blast
             apply(simp add: wf_chain_def)
             apply (meson ranI rule.sel(2))
             done
          with less have "y m. rset rs_called. r = Rule m (Call y)  (t. Γ,γ,p [Rule m (Call y)], Undecided  t)"
             apply(intro allI, rename_tac y my)
             apply(case_tac "matches γ my p")
              apply blast
             apply(intro ballI impI)
             apply(rule_tac x=Undecided in exI)
             apply(simp add: nomatch; fail)
             done
          from less.prems(4) rs_called rs_called  ran Γ
            helper_cases_call_subchain_defined_or_return[OF less.prems(3) less.prems(4) this ‹wf_chain Γ rs_called] have
            "(t. Γ,γ,p rs_called, Undecided  t) 
             (rs_called1 rs_called2 m'.
                  Γ chain_name_neu = Some (rs_called1@[Rule m' Return]@rs_called2) 
                  matches γ m' p  Γ,γ,p rs_called1, Undecided  Undecided)" by simp
          thus ?case
          proof(elim disjE exE conjE)
            fix t
            assume a: "Γ,γ,p rs_called, Undecided  t" show ?case
            using call_result[OF less.prems(1) rs_called a] by(blast)
          next
            fix m' rs_called1 rs_called2
            assume a1: "Γ chain_name_neu = Some (rs_called1 @ [Rule m' Return] @ rs_called2)"
            and a2: "matches γ m' p" and a3: "Γ,γ,p rs_called1, Undecided  Undecided"
            show ?case using call_return[OF less.prems(1) a1 a2 a3 ] by(blast)
          qed
        qed
        with True assms Call show ?thesis by simp
      qed
    qed
  with Undecided show ?thesis by simp
  qed
  
  
  private lemma helper_defined_ruleset_calledby: "wf (called_by_chain Γ)  
    rsg  ran Γ  {rs}. wf_chain Γ rsg 
    rsg  ran Γ  {rs}.  r  set rsg. (¬(chain. get_action r = Goto chain))  get_action r  Unknown 
     r  set rs. get_action r  Return 
    t. Γ,γ,p rs, s  t"
  apply(rule iptables_bigstep_defined_if_singleton_rules)
  apply(intro ballI, rename_tac r, case_tac r, rename_tac m a, simp)
  apply(rule helper_defined_single)
     apply(simp; fail)
    apply(simp add: wf_chain_def; fail)
   apply fastforce
  apply fastforce
  done
  
  corollary semantics_bigstep_defined: "finite (calls_chain Γ)  wf (calls_chain Γ)  ― ‹call relation finite and terminating›
    rsg  ran Γ  {rs}. wf_chain Γ rsg  ― ‹All calls to defined chains›
    rsg  ran Γ  {rs}.  r  set rsg. (x. get_action r  Goto x)  get_action r  Unknown  ― ‹no bad actions›
     r  set rs. get_action r  Return ― ‹no toplevel return› 
    t. Γ,γ,p rs, s  t"
  apply(drule(1) wf_called_by_chain)
  apply(thin_tac "wf (calls_chain Γ)")
  apply(rule helper_defined_ruleset_calledby)
     apply(simp_all)
  done
end









text‹Common Algorithms›

lemma iptables_bigstep_rm_LogEmpty: "Γ,γ,p rm_LogEmpty rs, s  t  Γ,γ,p rs, s  t"
proof(induction rs arbitrary: s)
case Nil thus ?case by(simp)
next
case (Cons r rs)
  have step_IH: "(s. Γ,γ,p rs1, s  t = Γ,γ,p rs2, s  t) 
         Γ,γ,p r#rs1, s  t = Γ,γ,p r#rs2, s  t" for rs1 rs2 r
  by (meson seq'_cons seqE_cons)
  have case_log: "Γ,γ,p Rule m Log # rs, s  t  Γ,γ,p rs, s  t" for m
    apply(rule iffI)
     apply(erule seqE_cons)
     apply (metis append_Nil log_remove seq')
    apply(rule_tac t=s in seq'_cons)
     apply(cases s)
      apply(cases "matches γ m p")
       apply(simp add: log; fail)
      apply(simp add: nomatch; fail)
     apply(simp add: decision; fail)
    apply simp
   done
  have case_empty: "Γ,γ,p Rule m Empty # rs, s  t  Γ,γ,p rs, s  t" for m
    apply(rule iffI)
     apply(erule seqE_cons)
     apply (metis append_Nil empty_empty seq')
    apply(rule_tac t=s in seq'_cons)
     apply(cases s)
      apply(cases "matches γ m p")
       apply(simp add: empty; fail)
      apply(simp add: nomatch; fail)
     apply(simp add: decision; fail)
    apply simp
   done

  from Cons show ?case  
  apply(cases r, rename_tac m a)
  apply(case_tac a)
          apply(simp_all)
          apply(simp_all cong: step_IH)
   apply(simp_all add: case_log case_empty)
  done
qed

lemma iptables_bigstep_rw_Reject: "Γ,γ,p rw_Reject rs, s  t  Γ,γ,p rs, s  t"
proof(induction rs arbitrary: s)
case Nil thus ?case by(simp)
next
case (Cons r rs)
  have step_IH: "(s. Γ,γ,p rs1, s  t = Γ,γ,p rs2, s  t) 
         Γ,γ,p r#rs1, s  t = Γ,γ,p r#rs2, s  t" for rs1 rs2 r
  by (meson seq'_cons seqE_cons)
  have fst_rule: "(t. Γ,γ,p [r1], s  t  Γ,γ,p [r2], s  t)  
    Γ,γ,p r1 # rs, s  t  Γ,γ,p r2 # rs, s  t" for r1 r2 rs s t
  by (meson seq'_cons seqE_cons)
  have dropreject: "Γ,γ,p [Rule m Drop], s  t = Γ,γ,p [Rule m Reject], s  t" for m t
    apply(cases s)
     apply(cases "matches γ m p")
      using drop reject dropD rejectD apply fast
     using nomatch nomatchD apply fast
    using decision decisionD apply fast
    done

  from Cons show ?case
  apply(cases r, rename_tac m a)
  apply simp
  apply(case_tac a)
          apply(simp_all)
          apply(simp_all cong: step_IH)
   apply(rule fst_rule)
   apply(simp add: dropreject)
  done
qed



end

Theory Matching

theory Matching
imports Semantics
begin

subsection‹Boolean Matcher Algebra›

lemma MatchOr: "matches γ (MatchOr m1 m2) p  matches γ m1 p  matches γ m2 p"
  by(simp add: MatchOr_def)

lemma opt_MatchAny_match_expr_correct: "matches γ (opt_MatchAny_match_expr m) = matches γ m"
 proof -
  have "matches γ (opt_MatchAny_match_expr_once m) = matches γ m" for m
   apply(simp add: fun_eq_iff)
   by(induction m rule: opt_MatchAny_match_expr_once.induct) (simp_all)
   thus ?thesis
    apply(simp add: opt_MatchAny_match_expr_def)
    apply(rule repeat_stabilize_induct)
     by(simp)+
 qed
    

lemma matcheq_matchAny: "¬ has_primitive m  matcheq_matchAny m  matches γ m p"
  by(induction m) simp_all

lemma matcheq_matchNone: "¬ has_primitive m  matcheq_matchNone m  ¬ matches γ m p"
  by(auto dest: matcheq_matchAny matachAny_matchNone)

lemma matcheq_matchNone_not_matches: "matcheq_matchNone m  ¬ matches γ m p"
  by(induction m rule: matcheq_matchNone.induct) auto


text‹Lemmas about matching in the @{const iptables_bigstep} semantics.›

lemma matches_rule_iptables_bigstep:
  assumes "matches γ m p  matches γ m' p"
  shows "Γ,γ,p [Rule m a], s  t  Γ,γ,p [Rule m' a], s  t" (is "?l ?r")
proof -
  {
    fix m m'
    assume "Γ,γ,p [Rule m a], s  t" "matches γ m p  matches γ m' p"
    hence "Γ,γ,p [Rule m' a], s  t"
      by (induction "[Rule  m a]" s t rule: iptables_bigstep_induct)
         (auto intro: iptables_bigstep.intros simp: Cons_eq_append_conv dest: skipD)
  }
  with assms show ?thesis by blast
qed

lemma matches_rule_and_simp_help:
  assumes "matches γ m p"
  shows "Γ,γ,p [Rule (MatchAnd m m') a'], Undecided  t  Γ,γ,p [Rule m' a'], Undecided  t" (is "?l ?r")
proof
  assume ?l thus ?r
    by (induction "[Rule (MatchAnd m m') a']" Undecided t rule: iptables_bigstep_induct)
       (auto intro: iptables_bigstep.intros simp: assms Cons_eq_append_conv dest: skipD)
next
  assume ?r thus ?l
    by (induction "[Rule m' a']" Undecided t rule: iptables_bigstep_induct)
       (auto intro: iptables_bigstep.intros simp: assms Cons_eq_append_conv dest: skipD)
qed

lemma matches_MatchNot_simp: 
  assumes "matches γ m p"
  shows "Γ,γ,p [Rule (MatchNot m) a], Undecided  t  Γ,γ,p [], Undecided  t" (is "?l  ?r")
proof
  assume ?l thus ?r
    by (induction "[Rule (MatchNot m) a]" "Undecided" t rule: iptables_bigstep_induct)
       (auto intro: iptables_bigstep.intros simp: assms Cons_eq_append_conv dest: skipD)
next
  assume ?r
  hence "t = Undecided"
    by (metis skipD)
  with assms show ?l
    by (fastforce intro: nomatch)
qed

lemma matches_MatchNotAnd_simp:
  assumes "matches γ m p"
  shows "Γ,γ,p [Rule (MatchAnd (MatchNot m) m') a], Undecided  t  Γ,γ,p [], Undecided  t" (is "?l  ?r")
proof
  assume ?l thus ?r
    by (induction "[Rule (MatchAnd (MatchNot m) m') a]" "Undecided" t rule: iptables_bigstep_induct)
       (auto intro: iptables_bigstep.intros simp add: assms Cons_eq_append_conv dest: skipD)
next
  assume ?r
  hence "t = Undecided"
    by (metis skipD)
  with assms show ?l
    by (fastforce intro: nomatch)
qed
  
lemma matches_rule_and_simp:
  assumes "matches γ m p"
  shows "Γ,γ,p [Rule (MatchAnd m m') a'], s  t  Γ,γ,p [Rule m' a'], s  t"
proof (cases s)
  case Undecided
  with assms show ?thesis
    by (simp add: matches_rule_and_simp_help)
next
  case Decision
  thus ?thesis by (metis decision decisionD)
qed

lemma iptables_bigstep_MatchAnd_comm:
  "Γ,γ,p [Rule (MatchAnd m1 m2) a], s  t  Γ,γ,p [Rule (MatchAnd m2 m1) a], s  t"
proof -
  { fix m1 m2
    have "Γ,γ,p [Rule (MatchAnd m1 m2) a], s  t  Γ,γ,p [Rule (MatchAnd m2 m1) a], s  t"
      proof (induction "[Rule (MatchAnd m1 m2) a]" s t rule: iptables_bigstep_induct)
        case Seq thus ?case
          by (metis Nil_is_append_conv append_Nil butlast_append butlast_snoc seq)
      qed (auto intro: iptables_bigstep.intros)
  }
  thus ?thesis by blast
qed


subsection‹Add match›

definition add_match :: "'a match_expr  'a rule list  'a rule list" where
  "add_match m rs = map (λr. case r of Rule m' a'  Rule (MatchAnd m m') a') rs"

lemma add_match_split: "add_match m (rs1@rs2) = add_match m rs1 @ add_match m rs2"
  unfolding add_match_def
  by (fact map_append)

lemma add_match_split_fst: "add_match m (Rule m' a' # rs) = Rule (MatchAnd m m') a' # add_match m rs"
  unfolding add_match_def
  by simp


lemma add_match_distrib:
  "Γ,γ,p add_match m1 (add_match m2 rs), s  t  Γ,γ,p add_match m2 (add_match m1 rs), s  t"
proof -
  {
    fix m1 m2
    have "Γ,γ,p add_match m1 (add_match m2 rs), s  t  Γ,γ,p add_match m2 (add_match m1 rs), s  t"
      proof (induction rs arbitrary: s)
        case Nil thus ?case by (simp add: add_match_def)
        next
        case (Cons r rs)
        from Cons obtain m a where r: "r = Rule m a" by (cases r) simp
        with Cons.prems obtain ti where 1: "Γ,γ,p [Rule (MatchAnd m1 (MatchAnd m2 m)) a], s  ti" and 2: "Γ,γ,p add_match m1 (add_match m2 rs), ti  t"
          apply(simp add: add_match_split_fst)
          apply(erule seqE_cons)
          by simp
        from 1 r have base: "Γ,γ,p [Rule (MatchAnd m2 (MatchAnd m1 m)) a], s  ti"
           by (metis matches.simps(1) matches_rule_iptables_bigstep)
        from 2 Cons.IH have IH: "Γ,γ,p add_match m2 (add_match m1 rs), ti  t" by simp
        from base IH seq'_cons have "Γ,γ,p Rule (MatchAnd m2 (MatchAnd m1 m)) a # add_match m2 (add_match m1 rs), s  t" by fast
        thus ?case using r by(simp add: add_match_split_fst[symmetric])
      qed
  }
  thus ?thesis by blast
qed

lemma add_match_split_fst': "add_match m (a # rs) = add_match m [a] @ add_match m rs"
  by (simp add: add_match_split[symmetric])



lemma matches_add_match_simp:
  assumes m: "matches γ m p"
  shows "Γ,γ,p add_match m rs, s  t  Γ,γ,p rs, s  t" (is "?l  ?r")
  proof
    assume ?l with m show ?r
      proof (induction rs)
        case Nil
        thus ?case
          unfolding add_match_def by simp
      next
        case (Cons r rs)
        hence IH: "Γ,γ,p add_match m rs, s  t  Γ,γ,p rs, s  t" by(simp add: add_match_split_fst)
        obtain m' a where r: "r = Rule m' a" by (cases r)
        with Cons.prems(2) obtain ti where "Γ,γ,p [Rule (MatchAnd m m') a], s  ti" and "Γ,γ,p add_match m rs, ti  t"
          by(auto elim:seqE_cons simp add: add_match_split_fst)
        with Cons.prems(1) IH have "Γ,γ,p [Rule m' a], s  ti" by(simp add: matches_rule_and_simp)
        with Γ,γ,p add_match m rs, ti  t IH r show ?case by(metis decision state.exhaust iptables_bigstep_deterministic seq_cons)
      qed
  next
    assume ?r with m show ?l
      proof (induction rs)
        case Nil
        thus ?case
          unfolding add_match_def by simp
      next
        case (Cons r rs)
        hence IH: " Γ,γ,p rs, s  t  Γ,γ,p add_match m rs, s  t" by(simp add: add_match_split_fst)
        obtain m' a where r: "r = Rule m' a" by (cases r)
        with Cons.prems(2) obtain ti where "Γ,γ,p [Rule m' a], s  ti" and "Γ,γ,p rs, ti  t"
          by(auto elim:seqE_cons simp add: add_match_split_fst)
        with Cons.prems(1) IH have "Γ,γ,p [Rule (MatchAnd m m') a], s  ti" by(simp add: matches_rule_and_simp)
        with Γ,γ,p rs, ti  t IH r show ?case 
          apply(simp add: add_match_split_fst)
          by(metis decision state.exhaust iptables_bigstep_deterministic seq_cons)
      qed
  qed

lemma matches_add_match_MatchNot_simp:
  assumes m: "matches γ m p"
  shows "Γ,γ,p add_match (MatchNot m) rs, s  t  Γ,γ,p [], s  t" (is "?l s  ?r s")
  proof (cases s)
    case Undecided
    have "?l Undecided  ?r Undecided"
      proof
        assume "?l Undecided" with m show "?r Undecided"
          proof (induction rs)
            case Nil
            thus ?case
              unfolding add_match_def by simp
          next
            case (Cons r rs)
            thus ?case
              by (cases r) (metis matches_MatchNotAnd_simp skipD seqE_cons add_match_split_fst)
          qed
      next
        assume "?r Undecided" with m show "?l Undecided"
          proof (induction rs)
            case Nil
            thus ?case
              unfolding add_match_def by simp
          next
            case (Cons r rs)
            thus ?case
              by (cases r) (metis matches_MatchNotAnd_simp skipD seq'_cons add_match_split_fst)
          qed
      qed
    with Undecided show ?thesis by fast
  next
    case (Decision d)
    thus ?thesis
      by(metis decision decisionD)
  qed

lemma not_matches_add_match_simp:
  assumes "¬ matches γ m p"
  shows "Γ,γ,p add_match m rs, Undecided  t  Γ,γ,p [], Undecided  t"
  proof(induction rs)
    case Nil
    thus ?case
      unfolding add_match_def by simp
  next
    case (Cons r rs)
    thus ?case
      by (cases r) (metis assms add_match_split_fst matches.simps(1) nomatch seq'_cons nomatchD seqE_cons)
  qed

lemma iptables_bigstep_add_match_notnot_simp: 
  "Γ,γ,p add_match (MatchNot (MatchNot m)) rs, s  t  Γ,γ,p add_match m rs, s  t"
  proof(induction rs)
    case Nil
    thus ?case
      unfolding add_match_def by simp
  next
    case (Cons r rs)
    thus ?case
      by (cases r)
         (metis decision decisionD state.exhaust matches.simps(2) matches_add_match_simp not_matches_add_match_simp)
  qed


lemma add_match_match_not_cases:
  "Γ,γ,p add_match (MatchNot m) rs, Undecided  Undecided  matches γ m p  Γ,γ,p rs, Undecided  Undecided"
  by (metis matches.simps(2) matches_add_match_simp)


lemma not_matches_add_matchNot_simp:
  "¬ matches γ m p  Γ,γ,p add_match (MatchNot m) rs, s  t  Γ,γ,p rs, s  t"
  by (simp add: matches_add_match_simp)

lemma iptables_bigstep_add_match_and:
  "Γ,γ,p add_match m1 (add_match m2 rs), s  t  Γ,γ,p add_match (MatchAnd m1 m2) rs, s  t"
  proof(induction rs arbitrary: s t)
    case Nil
    thus ?case
      unfolding add_match_def by simp
  next
    case(Cons r rs)
    show ?case
    proof (cases r, simp only: add_match_split_fst)
      fix m a
      show "Γ,γ,p Rule (MatchAnd m1 (MatchAnd m2 m)) a # add_match m1 (add_match m2 rs), s  t  Γ,γ,p Rule (MatchAnd (MatchAnd m1 m2) m) a # add_match (MatchAnd m1 m2) rs, s  t" (is "?l  ?r")
      proof
        assume ?l with Cons.IH show ?r
          apply -
          apply(erule seqE_cons)
          apply(case_tac s)
          apply(case_tac ti)
          apply (metis matches.simps(1) matches_rule_and_simp matches_rule_and_simp_help nomatch seq'_cons)
          apply (metis add_match_split_fst matches.simps(1) matches_add_match_simp not_matches_add_match_simp seq_cons)
          apply (metis decision decisionD)
          done
      next
        assume ?r with Cons.IH show ?l
          apply -
          apply(erule seqE_cons)
          apply(case_tac s)
          apply(case_tac ti)
          apply (metis matches.simps(1) matches_rule_and_simp matches_rule_and_simp_help nomatch seq'_cons)
          apply (metis add_match_split_fst matches.simps(1) matches_add_match_simp not_matches_add_match_simp seq_cons)
          apply (metis decision decisionD)
          done
        qed
    qed
  qed


lemma optimize_matches_option_generic:
  assumes " r  set rs. P (get_match r)"
      and "(m m'. P m  f m = Some m'  matches γ m' p = matches γ m p)"
      and "(m. P m  f m = None  ¬ matches γ m p)"
  shows "Γ,γ,p optimize_matches_option f rs, s  t  Γ,γ,p rs, s  t"
      (is "?lhs  ?rhs")
  proof
    assume ?rhs
    from this assms show ?lhs
    apply(induction rs s t rule: iptables_bigstep_induct)
    apply(auto simp: optimize_matches_option_append intro: iptables_bigstep.intros split: option.split)
    done
  next
    assume ?lhs
    from this assms show ?rhs
    apply(induction f rs arbitrary: s rule: optimize_matches_option.induct)
     apply(simp; fail)
    apply(simp split: option.split_asm)
     apply(subgoal_tac "¬ matches γ m p")
     prefer 2 apply blast
    apply (metis decision nomatch seq'_cons state.exhaust)
    apply(erule seqE_cons)
    apply(rule_tac t=ti in seq'_cons)
     apply (meson matches_rule_iptables_bigstep)
    by blast
  qed

lemma optimize_matches_generic: " r  set rs. P (get_match r)  
      (m. P m  matches γ (f m) p = matches γ m p) 
      Γ,γ,p optimize_matches f rs, s  t  Γ,γ,p rs, s  t"
  unfolding optimize_matches_def
  apply(rule optimize_matches_option_generic)
    apply(simp; fail)
   apply(simp split: if_split_asm)
   apply blast
  apply(simp split: if_split_asm)
  using matcheq_matchNone_not_matches by fast
end

Theory Ruleset_Update

theory Ruleset_Update
imports Matching
begin

lemma free_return_not_match: "Γ,γ,p [Rule m Return], Undecided  t  ¬ matches γ m p"
  using no_free_return by fast


subsection‹Background Ruleset Updating›
lemma update_Gamma_nomatch: 
  assumes "¬ matches γ m p"
  shows "Γ(chain  Rule m a # rs),γ,p rs', s  t  Γ(chain  rs),γ,p rs', s  t" (is "?l  ?r")
  proof
    assume ?l thus ?r
      proof (induction rs' s t rule: iptables_bigstep_induct)
        case (Call_return m a chain' rs1 m' rs2)
        thus ?case
          proof (cases "chain' = chain")
            case True
            with Call_return show ?thesis
              apply simp
              apply(cases "rs1")
              using assms apply fastforce
              apply(rule_tac rs1="list" and m'="m'" and rs2="rs2" in call_return)
                 apply(simp)
                apply(simp)
               apply(simp)
              apply(simp)
              apply(erule seqE_cons[where Γ="(λa. if a = chain then Some rs else Γ a)"])
              apply(frule iptables_bigstep_to_undecided[where Γ="(λa. if a = chain then Some rs else Γ a)"])
              apply(simp)
              done
          qed (auto intro: call_return)
      next
        case (Call_result m' a' chain' rs' t')
        have "Γ(chain  rs),γ,p [Rule m' (Call chain')], Undecided  t'"
          proof (cases "chain' = chain")
            case True
            with Call_result have "Rule m a # rs = rs'" "(Γ(chain  rs)) chain' = Some rs"
              by simp+
            with assms Call_result show ?thesis
              by (metis call_result nomatchD seqE_cons)
          next
            case False
            with Call_result show ?thesis
              by (metis call_result fun_upd_apply)
          qed
        with Call_result show ?case
          by fast
      qed (auto intro: iptables_bigstep.intros)
  next
    assume ?r thus ?l
      proof (induction rs' s t rule: iptables_bigstep_induct)
        case (Call_return m' a' chain' rs1)
        thus ?case
          proof (cases "chain' = chain")
            case True
            with Call_return show ?thesis
              using assms
              by (auto intro: seq_cons nomatch intro!: call_return[where rs1 = "Rule m a # rs1"])
          qed (auto intro: call_return)
      next
        case (Call_result m' a' chain' rs')
        thus ?case
          proof (cases "chain' = chain")
            case True
            with Call_result show ?thesis
              using assms by (auto intro: seq_cons nomatch intro!: call_result)
          qed (auto intro: call_result)
      qed (auto intro: iptables_bigstep.intros)
  qed

lemma update_Gamma_log_empty:
  assumes "a = Log  a = Empty"
  shows "Γ(chain  Rule m a # rs),γ,p rs', s  t 
         Γ(chain  rs),γ,p rs', s  t" (is "?l  ?r")
  proof
    assume ?l thus ?r
      proof (induction rs' s t rule: iptables_bigstep_induct)
        case (Call_return m' a' chain' rs1 m'' rs2)
        (*it seems that Isabelle has problems to apply @{thm fun_upd_apply} at the semantics if it appears in the goal without @{text λ}*)
        note [simp] = fun_upd_apply[abs_def]

        from Call_return have "Γ(chain  rs),γ,p [Rule m' (Call chain')], Undecided  Undecided" (is ?Call_return_case)
          proof(cases "chain' = chain")
          case True with Call_return show ?Call_return_case
            ― ‹@{term rs1} cannot be empty›
            proof(cases "rs1")
            case Nil with Call_return(3) chain' = chain assms have "False" by simp
              thus ?Call_return_case by simp
            next
            case (Cons r1 rs1s)
            from Cons Call_return have "Γ(chain  rs),γ,p r1 # rs1s, Undecided  Undecided" by blast
            with seqE_cons[where Γ="Γ(chain  rs)"] obtain ti where 
              "Γ(chain  rs),γ,p [r1], Undecided  ti" and "Γ(chain  rs),γ,p rs1s, ti  Undecided" by metis
            with iptables_bigstep_to_undecided[where Γ="Γ(chain  rs)"] have "Γ(chain  rs),γ,p rs1s, Undecided  Undecided" by fast
            with Cons Call_return chain' = chain show ?Call_return_case
               apply(rule_tac rs1="rs1s" and m'="m''" and rs2="rs2" in call_return)
                  apply(simp_all)
               done
             qed
          next
          case False with Call_return show ?Call_return_case
           by (auto intro: call_return)
          qed
        thus ?case using Call_return by blast
      next
        case (Call_result m' a' chain' rs' t')
        thus ?case
          proof (cases "chain' = chain")
            case True
            with Call_result have "rs' = [] @ [Rule m a] @ rs"
              by simp
            with Call_result assms have "Γ(chain  rs),γ,p [] @ rs, Undecided  t'"
              using log_remove empty_empty by fast
            hence "Γ(chain  rs),γ,p rs, Undecided  t'"
              by simp
            with Call_result True show ?thesis
              by (metis call_result fun_upd_same)
          qed (fastforce intro: call_result)
      qed (auto intro: iptables_bigstep.intros)
  next
    have cases_a: "P. (a = Log  P a)  (a = Empty  P a)  P a" using assms by blast
    assume ?r thus ?l
      proof (induction rs' s t rule: iptables_bigstep_induct)
        case (Call_return m' a' chain' rs1 m'' rs2)
        from Call_return have xx: "Γ(chain  Rule m a # rs),γ,p Rule m a # rs1, Undecided  Undecided"
          apply -
          apply(rule cases_a)
          apply (auto intro: nomatch seq_cons intro!: log empty simp del: fun_upd_apply)
          done
        with Call_return show ?case
          proof(cases "chain' = chain")
            case False
            with Call_return have x: "(Γ(chain  Rule m a # rs)) chain' = Some (rs1 @ Rule m'' Return # rs2)"
              by(simp)
            with Call_return have "Γ(chain  Rule m a # rs),γ,p [Rule m' (Call chain')], Undecided  Undecided"
             apply -
             apply(rule call_return[where rs1="rs1" and m'="m''" and rs2="rs2"])
                apply(simp_all add: x xx del: fun_upd_apply)
             done
             thus "Γ(chain  Rule m a # rs),γ,p [Rule m' a'], Undecided  Undecided" using Call_return by simp
            next
            case True
            with Call_return have x: "(Γ(chain  Rule m a # rs)) chain' = Some (Rule m a # rs1 @ Rule m'' Return # rs2)"
              by(simp)
            with Call_return have "Γ(chain  Rule m a # rs),γ,p [Rule m' (Call chain')], Undecided  Undecided"
             apply -
             apply(rule call_return[where rs1="Rule m a#rs1" and m'="m''" and rs2="rs2"])
                apply(simp_all add: x xx del: fun_upd_apply)
             done
             thus "Γ(chain  Rule m a # rs),γ,p [Rule m' a'], Undecided  Undecided" using Call_return by simp
          qed
      next
        case (Call_result ma a chaina rs t)
        thus ?case
          apply (cases "chaina = chain")
           apply(rule cases_a)
            apply (auto intro: nomatch seq_cons intro!: log empty call_result)[2]
          by (auto intro!: call_result)[1]
      qed (auto intro: iptables_bigstep.intros)
  qed

lemma map_update_chain_if: "(λb. if b = chain then Some rs else Γ b) = Γ(chain  rs)"
  by auto

lemma no_recursive_calls_helper:
  assumes "Γ,γ,p [Rule m (Call chain)], Undecided  t"
  and     "matches γ m p"
  and     "Γ chain = Some [Rule m (Call chain)]"
  shows   False
  using assms
  proof (induction "[Rule m (Call chain)]" Undecided t rule: iptables_bigstep_induct)
    case Seq
    thus ?case
      by (metis Cons_eq_append_conv append_is_Nil_conv skipD)
  next
    case (Call_return chain' rs1 m' rs2)
    hence "rs1 @ Rule m' Return # rs2 = [Rule m (Call chain')]"
      by simp
    thus ?case
      by (cases "rs1") auto
  next
    case Call_result
    thus ?case
      by simp
  qed (auto intro: iptables_bigstep.intros)

lemma no_recursive_calls:
  "Γ(chain  [Rule m (Call chain)]),γ,p [Rule m (Call chain)], Undecided  t  matches γ m p  False"
  by (fastforce intro: no_recursive_calls_helper)

lemma no_recursive_calls2:
  assumes "Γ(chain  (Rule m (Call chain)) # rs''),γ,p (Rule m (Call chain)) # rs', Undecided  Undecided"
  and     "matches γ m p"
  shows   False
  using assms
  proof (induction "(Rule m (Call chain)) # rs'" Undecided Undecided arbitrary: rs' rule: iptables_bigstep_induct)
    case (Seq rs1 rs2 t)
    thus ?case
      by (cases rs1) (auto elim: seqE_cons simp add: iptables_bigstep_to_undecided)
  qed (auto intro: iptables_bigstep.intros simp: Cons_eq_append_conv)


lemma update_Gamma_nochange1: 
  assumes "Γ(chain  rs),γ,p [Rule m a], Undecided  Undecided"
  and     "Γ(chain  Rule m a # rs),γ,p rs', s  t"
  shows   "Γ(chain  rs),γ,p rs', s  t"
  using assms(2) proof (induction rs' s t rule: iptables_bigstep_induct)
    case (Call_return m a chaina rs1 m' rs2)
    thus ?case
      proof (cases "chaina = chain")
        case True
        with Call_return show ?thesis
          apply simp
          apply(cases "rs1")
          apply(simp)
          using assms apply (metis no_free_return) (*gives False*)
          apply(rule_tac rs1="list" and m'="m'" and rs2="rs2" in call_return)
          apply(simp)
          apply(simp)
          apply(simp)
          apply(simp)
          apply(erule seqE_cons[where Γ="(λa. if a = chain then Some rs else Γ a)"])
          apply(frule iptables_bigstep_to_undecided[where Γ="(λa. if a = chain then Some rs else Γ a)"])
          apply(simp)
          done
      qed (auto intro: call_return)
  next
    case (Call_result m a chaina rsa t)
    thus ?case
      proof (cases "chaina = chain")
        case True
        with Call_result show ?thesis
          apply(simp)
          apply(cases "rsa")
           apply(simp)
           apply(rule_tac rs=rs in call_result)
            apply(simp_all)
          apply(erule_tac seqE_cons[where Γ="(λb. if b = chain then Some rs else Γ b)"])
          apply(case_tac t)
           apply(simp)
           apply(frule iptables_bigstep_to_undecided[where Γ="(λb. if b = chain then Some rs else Γ b)"])
           apply(simp)
          apply(simp)
          apply(subgoal_tac "ti = Undecided")
           apply(simp)
          using assms(1)[simplified map_update_chain_if[symmetric]] iptables_bigstep_deterministic apply fast
          done
      qed (fastforce intro: call_result)
  qed (auto intro: iptables_bigstep.intros)

lemma update_gamme_remove_Undecidedpart:
  assumes "Γ(chain  rs'),γ,p rs', Undecided  Undecided"
  and     "Γ(chain  rs1@rs'),γ,p rs, Undecided  Undecided"
  shows   "Γ(chain rs'),γ,p rs, Undecided  Undecided"
  using assms(2) proof (induction rs Undecided Undecided rule: iptables_bigstep_induct)
    case Seq
    thus ?case
      by (auto simp: iptables_bigstep_to_undecided intro: seq)
  next
    case (Call_return m a chaina rs1 m' rs2)
    thus ?case
      apply(cases "chaina = chain")
       apply(simp)
       apply(cases "length rs1  length rs1")
        apply(simp add: List.append_eq_append_conv_if)
        apply(rule_tac rs1="drop (length rs1) rs1" and m'=m' and rs2=rs2 in call_return)
          apply(simp_all)[3]
        apply(subgoal_tac "rs1 = (take (length rs1) rs1) @ drop (length rs1) rs1")
         prefer 2 apply (metis append_take_drop_id)
        apply(clarify)
        apply(subgoal_tac "Γ(chain  drop (length rs1) rs1 @ Rule m' Return # rs2),γ,p 
            (take (length rs1) rs1) @ drop (length rs1) rs1, Undecided  Undecided")
         prefer 2 apply(auto)[1]
        apply(erule_tac rs1="take (length rs1) rs1" and rs2="drop (length rs1) rs1" in seqE)
        apply(simp)
        apply(frule_tac rs="drop (length rs1) rs1" in iptables_bigstep_to_undecided)
        apply(simp; fail) (*oh wow*)
       using assms apply (auto intro: call_result call_return)
      done
  next
    case (Call_result _ _ chain' rsa)
    thus ?case
      apply(cases "chain' = chain")
       apply(simp)
       apply(rule call_result)
         apply(simp_all)[2]
       apply (metis iptables_bigstep_to_undecided seqE)
      apply (auto intro: call_result)
      done
  qed (auto intro: iptables_bigstep.intros)

lemma update_Gamma_nocall:
  assumes "¬ (chain. a = Call chain)"
  shows "Γ,γ,p [Rule m a], s  t  Γ',γ,p [Rule m a], s  t"
  proof -
    {
      fix Γ Γ'
      have "Γ,γ,p [Rule m a], s  t  Γ',γ,p [Rule m a], s  t"
        proof (induction "[Rule m a]" s t rule: iptables_bigstep_induct)
          case Seq
          thus ?case by (metis (lifting, no_types) list_app_singletonE[where x = "Rule m a"] skipD)
        next
          case Call_return thus ?case using assms by metis
        next
          case Call_result thus ?case using assms by metis
        qed (auto intro: iptables_bigstep.intros)
    }
    thus ?thesis
      by blast
  qed

lemma update_Gamma_call:
  assumes "Γ chain = Some rs" and "Γ' chain = Some rs'"
  assumes "Γ,γ,p rs, Undecided  Undecided" and "Γ',γ,p rs', Undecided  Undecided"
  shows "Γ,γ,p [Rule m (Call chain)], s  t  Γ',γ,p [Rule m (Call chain)], s  t"
  proof -
    {
      fix Γ Γ' rs rs'
      assume assms:
        "Γ chain = Some rs" "Γ' chain = Some rs'"
        "Γ,γ,p rs, Undecided  Undecided" "Γ',γ,p rs', Undecided  Undecided"
      have "Γ,γ,p [Rule m (Call chain)], s  t  Γ',γ,p [Rule m (Call chain)], s  t"
        proof (induction "[Rule m (Call chain)]" s t rule: iptables_bigstep_induct)
          case Seq
          thus ?case by (metis (lifting, no_types) list_app_singletonE[where x = "Rule m (Call chain)"] skipD)
        next
          case Call_result
          thus ?case
            using assms by (metis call_result iptables_bigstep_deterministic)
        qed (auto intro: iptables_bigstep.intros assms)
    }
    note * = this
    show ?thesis
      using *[OF assms(1-4)] *[OF assms(2,1,4,3)] by blast
  qed

lemma update_Gamma_remove_call_undecided:
  assumes "Γ(chain  Rule m (Call foo) # rs'),γ,p rs, Undecided  Undecided"
  and     "matches γ m p"
  shows "Γ(chain  rs'),γ,p rs, Undecided  Undecided"
  using assms
  proof (induction rs Undecided Undecided arbitrary: rule: iptables_bigstep_induct)
    case Seq
    thus ?case
      by (force simp: iptables_bigstep_to_undecided intro: seq')
  next
    case (Call_return m a chaina rs1 m' rs2)
    thus ?case
      apply(cases "chaina = chain")
      apply(cases "rs1")
      apply(force intro: call_return)
      apply(simp)
      apply(erule_tac Γ="Γ(chain  list @ Rule m' Return # rs2)" in seqE_cons)
      apply(frule_tac Γ="Γ(chain  list @ Rule m' Return # rs2)" in iptables_bigstep_to_undecided)
      apply(auto intro: call_return)
      done
  next
    case (Call_result m a chaina rsa)
    thus ?case
      apply(cases "chaina = chain")
      apply(simp)
      apply (metis call_result fun_upd_same iptables_bigstep_to_undecided seqE_cons)
      apply (auto intro: call_result)
      done
  qed (auto intro: iptables_bigstep.intros)

lemma all_return_subchain:
  assumes a1: "Γ chain = Some rs"
  and     a2: "matches γ m p"
  and     a3: "rset rs. get_action r = Return"
  shows "Γ,γ,p [Rule m (Call chain)], Undecided  Undecided"
  proof (cases "r  set rs. matches γ (get_match r) p")
    case True
    hence "(rs1 r rs2. rs = rs1 @ r # rs2  matches γ (get_match r) p  (r'set rs1. ¬ matches γ (get_match r') p))"
      by (subst split_list_first_prop_iff[symmetric])
    then obtain rs1 r rs2
      where *: "rs = rs1 @ r # rs2" "matches γ (get_match r) p" "r'set rs1. ¬ matches γ (get_match r') p"
      by auto

    with a3 obtain m' where "r = Rule m' Return"
      by (cases r) simp
    with * assms show ?thesis
      by (fastforce intro: call_return nomatch')
  next
    case False
    hence "Γ,γ,p rs, Undecided  Undecided"
      by (blast intro: nomatch')
    with a1 a2 show ?thesis
      by (metis call_result)
qed


lemma get_action_case_simp: "get_action (case r of Rule m' x  Rule (MatchAnd m m') x) = get_action r"
by (metis rule.case_eq_if rule.sel(2))


lemma updategamma_insert_new: "Γ,γ,p rs, s  t  chain  dom Γ  Γ(chain  rs'),γ,p rs, s  t"
proof(induction rule: iptables_bigstep_induct)
case (Call_result m a chain' rs t)
  thus ?case by (metis call_result domI fun_upd_def)
next
case Call_return
  thus ?case by (metis call_return domI fun_upd_def)
qed(auto intro: iptables_bigstep.intros)




end

Theory Call_Return_Unfolding

theory Call_Return_Unfolding
imports Matching Ruleset_Update
  "Common/Repeat_Stabilize"
begin


section@{term Call} @{term Return} Unfolding›

text‹Remove @{term Return}s›
fun process_ret :: "'a rule list  'a rule list" where
  "process_ret [] = []" |
  "process_ret (Rule m Return # rs) = add_match (MatchNot m) (process_ret rs)" |
  "process_ret (r#rs) = r # process_ret rs"


text‹Remove @{term Call}s›
fun process_call :: "'a ruleset  'a rule list  'a rule list" where
  "process_call Γ [] = []" |
  "process_call Γ (Rule m (Call chain) # rs) = add_match m (process_ret (the (Γ chain))) @ process_call Γ rs" |
  "process_call Γ (r#rs) = r # process_call Γ rs"

lemma process_ret_split_fst_Return:
  "a = Return  process_ret (Rule m a # rs) = add_match (MatchNot m) (process_ret rs)"
  by auto

lemma process_ret_split_fst_NeqReturn:
  "a  Return  process_ret((Rule m a) # rs) = (Rule m a) # (process_ret rs)"
  by (cases a) auto

lemma add_match_simp: "add_match m = map (λr. Rule (MatchAnd m (get_match r)) (get_action r))"
by (auto simp: add_match_def cong: map_cong split: rule.split)

definition add_missing_ret_unfoldings :: "'a rule list  'a rule list  'a rule list" where
  "add_missing_ret_unfoldings rs1 rs2  
  foldr (λrf acc. add_match (MatchNot (get_match rf))  acc) [rrs1. get_action r = Return] id rs2"


fun MatchAnd_foldr :: "'a match_expr list  'a match_expr" where
  "MatchAnd_foldr [] = undefined" | (*error, semantically, MatchAny would match*)
  "MatchAnd_foldr [e] = e" |
  "MatchAnd_foldr (e # es) = MatchAnd e (MatchAnd_foldr es)" 
fun add_match_MatchAnd_foldr :: "'a match_expr list  ('a rule list  'a rule list)" where
  "add_match_MatchAnd_foldr [] = id" |
  "add_match_MatchAnd_foldr es = add_match (MatchAnd_foldr es)"

lemma add_match_add_match_MatchAnd_foldr:
  "Γ,γ,p add_match m (add_match_MatchAnd_foldr ms rs2), s  t = Γ,γ,p add_match (MatchAnd_foldr (m#ms)) rs2, s  t"
  proof (induction ms)
    case Nil
    show ?case by (simp add: add_match_def)
  next
    case Cons
    thus ?case by (simp add: iptables_bigstep_add_match_and)
  qed

lemma add_match_MatchAnd_foldr_empty_rs2: "add_match_MatchAnd_foldr ms [] = []"
  by (induction ms) (simp_all add: add_match_def)

lemma add_missing_ret_unfoldings_alt: "Γ,γ,p add_missing_ret_unfoldings rs1 rs2, s  t 
  Γ,γ,p (add_match_MatchAnd_foldr (map (λr. MatchNot (get_match r)) [rrs1. get_action r = Return])) rs2, s   t"
  proof(induction rs1)
    case Nil
    thus ?case
      unfolding add_missing_ret_unfoldings_def by simp
  next
    case (Cons r rs)
    from Cons obtain m a where "r = Rule m a" by(cases r) (simp)
    with Cons show ?case
      unfolding add_missing_ret_unfoldings_def
      apply(cases "matches γ m p")
       apply (simp_all add: matches_add_match_simp matches_add_match_MatchNot_simp add_match_add_match_MatchAnd_foldr[symmetric])
      done
  qed

lemma add_match_add_missing_ret_unfoldings_rot:
  "Γ,γ,p add_match m (add_missing_ret_unfoldings rs1 rs2), s  t =  
   Γ,γ,p add_missing_ret_unfoldings (Rule (MatchNot m) Return#rs1) rs2, s  t"
  by(simp add: add_missing_ret_unfoldings_def iptables_bigstep_add_match_notnot_simp)


subsection‹Completeness›
lemma process_ret_split_obvious: "process_ret (rs1 @ rs2) = 
  (process_ret rs1) @ (add_missing_ret_unfoldings rs1 (process_ret rs2))"
  unfolding add_missing_ret_unfoldings_def
  proof (induction rs1 arbitrary: rs2)
    case (Cons r rs)
    from Cons obtain m a where "r = Rule m a" by (cases r) simp
    with Cons.IH show ?case
      apply(cases a)
             apply(simp_all add: add_match_split)
      done
  qed simp

lemma add_missing_ret_unfoldings_emptyrs2: "add_missing_ret_unfoldings rs1 [] = []"
  unfolding add_missing_ret_unfoldings_def
  by (induction rs1) (simp_all add: add_match_def)

lemma process_call_split: "process_call Γ (rs1 @ rs2) = process_call Γ rs1 @ process_call Γ rs2"
  proof (induction rs1)
    case (Cons r rs1)
    thus ?case
      apply(cases r, rename_tac m a)
      apply(case_tac a)
              apply(simp_all)
      done
  qed simp

lemma process_call_split_fst: "process_call Γ (a # rs) = process_call Γ [a] @ process_call Γ rs"
  by (simp add: process_call_split[symmetric])


lemma iptables_bigstep_process_ret_undecided: "Γ,γ,p rs, Undecided  t  Γ,γ,p process_ret rs, Undecided  t"
proof (induction rs)
  case (Cons r rs)
  show ?case
    proof (cases r)
      case (Rule m' a')
      show "Γ,γ,p process_ret (r # rs), Undecided  t"
        proof (cases a')
          case Accept
          with Cons Rule show ?thesis
            by simp (metis acceptD decision decisionD nomatchD seqE_cons seq_cons)
        next
          case Drop
          with Cons Rule show ?thesis
            by simp (metis decision decisionD dropD nomatchD seqE_cons seq_cons)
        next
          case Log
          with Cons Rule show ?thesis
            by simp (metis logD nomatchD seqE_cons seq_cons)
        next
          case Reject
          with Cons Rule show ?thesis
            by simp (metis decision decisionD nomatchD rejectD seqE_cons seq_cons)
        next
          case (Call chain)
          from Cons.prems obtain ti where 1:"Γ,γ,p [r], Undecided  ti" and 2: "Γ,γ,p rs, ti  t" using seqE_cons by metis
          thus ?thesis
            proof(cases ti)
            case Undecided
              with Cons.IH 2 have IH: "Γ,γ,p process_ret rs, Undecided  t" by simp
              from Undecided 1 Call Rule have "Γ,γ,p [Rule m' (Call chain)], Undecided  Undecided" by simp
              with IH  have" Γ,γ,p Rule m' (Call chain) # process_ret rs, Undecided  t" using seq'_cons by fast
              thus ?thesis using Rule Call by force
            next
            case (Decision X)
              with 1 Rule Call have "Γ,γ,p [Rule m' (Call chain)], Undecided  Decision X" by simp
              moreover from 2 Decision have "t = Decision X" using decisionD by fast
              moreover from decision have "Γ,γ,p process_ret rs, Decision X  Decision X" by fast
              ultimately show ?thesis using seq_cons by (metis Call Rule process_ret.simps(7))
            qed
        next
          case Return
          with Cons Rule show ?thesis
            by simp (metis matches.simps(2) matches_add_match_simp no_free_return nomatchD seqE_cons)
        next
          case Empty
          show ?thesis 
            apply (insert Empty Cons Rule)
            apply(erule seqE_cons)
            apply (rename_tac ti)
            apply(case_tac ti)
             apply (simp add: seq_cons)
            apply (metis Rule_DecisionE emptyD state.distinct(1))
            done
        next
          case Unknown
          show ?thesis using Unknown_actions_False
            by (metis Cons.IH Cons.prems Rule Unknown nomatchD process_ret.simps(10) seqE_cons seq_cons)
        next
          case Goto thus ?thesis  using Unknown_actions_False
            by (metis Cons.IH Cons.prems Rule Goto nomatchD process_ret.simps(8) seqE_cons seq_cons) 
        qed
    qed
qed simp


lemma add_match_rot_add_missing_ret_unfoldings:
  "Γ,γ,p add_match m (add_missing_ret_unfoldings rs1 rs2), Undecided  Undecided =
   Γ,γ,p add_missing_ret_unfoldings rs1 (add_match m rs2), Undecided  Undecided"
apply(simp add: add_missing_ret_unfoldings_alt add_match_add_missing_ret_unfoldings_rot add_match_add_match_MatchAnd_foldr[symmetric] iptables_bigstep_add_match_notnot_simp)
apply(cases "map (λr. MatchNot (get_match r)) [rrs1 . (get_action r) = Return]")
 apply(simp_all add: add_match_distrib)
done

text ‹Completeness›
theorem unfolding_complete: "Γ,γ,p rs,s  t    Γ,γ,p process_call Γ rs,s  t"
  proof (induction rule: iptables_bigstep_induct)
    case (Nomatch m a)
    thus ?case
      by (cases a) (auto intro: iptables_bigstep.intros simp add: not_matches_add_match_simp skip)
  next
    case Seq
    thus ?case
      by(simp add: process_call_split seq')
  next
    case (Call_return m a chain rs1 m' rs2)
    hence "Γ,γ,p rs1, Undecided  Undecided"
      by simp
    hence "Γ,γ,p process_ret rs1, Undecided  Undecided"
      by (rule iptables_bigstep_process_ret_undecided)
    with Call_return have "Γ,γ,p process_ret rs1 @ add_missing_ret_unfoldings rs1 (add_match (MatchNot m') (process_ret rs2)), Undecided  Undecided"
      by (metis matches_add_match_MatchNot_simp skip add_match_rot_add_missing_ret_unfoldings seq')
    with Call_return show ?case
      by (simp add: matches_add_match_simp process_ret_split_obvious)
  next
    case Call_result
    thus ?case
      by (simp add: matches_add_match_simp iptables_bigstep_process_ret_undecided)
  qed (auto intro: iptables_bigstep.intros)



lemma process_ret_cases:
  "process_ret rs = rs  (rs1 rs2 m. rs = rs1@[Rule m Return]@rs2  (process_ret rs) = rs1@(process_ret ([Rule m Return]@rs2)))"
  proof (induction rs)
    case (Cons r rs)
    thus ?case
      apply(cases r, rename_tac m' a')
      apply(case_tac a')
              apply(simp_all)
              apply(erule disjE,simp,rule disjI2,elim exE,simp add: process_ret_split_obvious,
                metis append_Cons process_ret_split_obvious process_ret.simps(2))+
         apply(rule disjI2)
         apply(rule_tac x="[]" in exI)
         apply(rule_tac x="rs" in exI)
         apply(rule_tac x="m'" in exI)
         apply(simp)
        apply(erule disjE,simp,rule disjI2,elim exE,simp add: process_ret_split_obvious,
           metis append_Cons process_ret_split_obvious process_ret.simps(2))+
      done
  qed simp

lemma process_ret_splitcases:
  obtains (id) "process_ret rs = rs"
        | (split) rs1 rs2 m where "rs = rs1@[Rule m Return]@rs2" and "process_ret rs = rs1@(process_ret ([Rule m Return]@rs2))"
 by (metis process_ret_cases)


lemma iptables_bigstep_process_ret_cases3:
  assumes "Γ,γ,p process_ret rs, Undecided  Undecided"
  obtains (noreturn) "Γ,γ,p rs, Undecided  Undecided"
        | (return) rs1 rs2 m where "rs = rs1@[Rule m Return]@rs2" "Γ,γ,p rs1, Undecided  Undecided" "matches γ m p"
proof -
  have "Γ,γ,p process_ret rs, Undecided  Undecided  
    (Γ,γ,p rs, Undecided  Undecided) 
    (rs1 rs2 m. rs = rs1@[Rule m Return]@rs2  Γ,γ,p rs1, Undecided  Undecided  matches γ m p)"
  proof (induction rs)
    case Nil thus ?case by simp
    next
    case (Cons r rs)
    from Cons obtain m a where r: "r = Rule m a" by (cases r) simp
    from r Cons show ?case
      proof(cases "a  Return")
        case True
        with r Cons.prems have prems_r: "Γ,γ,p [Rule m a], Undecided  Undecided " and prems_rs: "Γ,γ,p process_ret rs, Undecided  Undecided"
         apply(simp_all add: process_ret_split_fst_NeqReturn)
         apply(erule seqE_cons, frule iptables_bigstep_to_undecided, simp)+
         done
        from prems_rs Cons.IH have "Γ,γ,p rs, Undecided  Undecided 
                      (rs1 rs2 m. rs = rs1 @ [Rule m Return] @ rs2  Γ,γ,p rs1, Undecided  Undecided  matches γ m p)" by simp
        thus "Γ,γ,p r # rs, Undecided  Undecided  (rs1 rs2 m. r # rs = rs1 @ [Rule m Return] @ rs2  Γ,γ,p rs1, Undecided  Undecided  matches γ m p)"
          proof(elim disjE)
            assume "Γ,γ,p rs, Undecided  Undecided"
            hence "Γ,γ,p r # rs, Undecided  Undecided" using prems_r by (metis r seq'_cons) 
            thus ?thesis by simp
          next
            assume "(rs1 rs2 m. rs = rs1 @ [Rule m Return] @ rs2  Γ,γ,p rs1, Undecided  Undecided  matches γ m p)"
            from this obtain rs1 rs2 m' where "rs = rs1 @ [Rule m' Return] @ rs2" and "Γ,γ,p rs1, Undecided  Undecided" and "matches γ m' p" by blast
            hence "rs1 rs2 m. r # rs = rs1 @ [Rule m Return] @ rs2  Γ,γ,p rs1, Undecided  Undecided  matches γ m p"
              apply(rule_tac x="Rule m a # rs1" in exI)
              apply(rule_tac x=rs2 in exI)
              apply(rule_tac x=m' in exI)
              apply(simp add: r)
              using prems_r seq'_cons by fast
            thus ?thesis by simp
          qed
      next
      case False
        hence "a = Return" by simp
        with Cons.prems r have prems: "Γ,γ,p add_match (MatchNot m) (process_ret rs), Undecided  Undecided" by simp
        show "Γ,γ,p r # rs, Undecided  Undecided  (rs1 rs2 m. r # rs = rs1 @ [Rule m Return] @ rs2  Γ,γ,p rs1, Undecided  Undecided  matches γ m p)"
          proof(cases "matches γ m p")
          case True
            (*the Cons premises are useless in this case*)
            hence "rs1 rs2 m. r # rs = rs1 @ Rule m Return # rs2  Γ,γ,p rs1, Undecided  Undecided  matches γ m p"
               apply(rule_tac x="[]" in exI)
               apply(rule_tac x="rs" in exI)
               apply(rule_tac x="m" in exI)
               apply(simp add: skip r a = Return›)
               done
            thus ?thesis by simp
          next
          case False
            with nomatch seq_cons False r have r_nomatch: "rs. Γ,γ,p rs, Undecided  Undecided  Γ,γ,p r # rs, Undecided  Undecided" by fast
            note r_nomatch'=r_nomatch[simplified r a = Return›] ― ‹r unfolded›
            from False not_matches_add_matchNot_simp prems have "Γ,γ,p process_ret rs, Undecided  Undecided" by fast
            with Cons.IH have IH: "Γ,γ,p rs, Undecided  Undecided  (rs1 rs2 m. rs = rs1 @ [Rule m Return] @ rs2  Γ,γ,p rs1, Undecided  Undecided  matches γ m p)" .
            thus ?thesis
              proof(elim disjE)
                assume "Γ,γ,p rs, Undecided  Undecided"
                hence "Γ,γ,p r # rs, Undecided  Undecided" using r_nomatch by simp
                thus ?thesis by simp
              next
                assume "rs1 rs2 m. rs = rs1 @ [Rule m Return] @ rs2  Γ,γ,p rs1, Undecided  Undecided  matches γ m p"
                from this obtain rs1 rs2 m' where "rs = rs1 @ [Rule m' Return] @ rs2" and "Γ,γ,p rs1, Undecided  Undecided" and "matches γ m' p" by blast
                hence "rs1 rs2 m. r # rs = rs1 @ [Rule m Return] @ rs2  Γ,γ,p rs1, Undecided  Undecided  matches γ m p" 
                  apply(rule_tac x="Rule m Return # rs1" in exI)
                  apply(rule_tac x="rs2" in exI)
                  apply(rule_tac x="m'" in exI)
                  by(simp add:  a = Return› False r r_nomatch')
                thus ?thesis by simp
              qed
          qed
       qed
  qed
  with assms noreturn return show ?thesis by auto
qed

lemma iptables_bigstep_process_ret_DecisionD: "Γ,γ,p process_ret rs, s  Decision X  Γ,γ,p rs, s  Decision X"
proof (induction rs arbitrary: s)
  case (Cons r rs)
  thus ?case
    apply(cases r, rename_tac m a)
    apply(clarify)

    apply(case_tac "a  Return")
    apply(simp add: process_ret_split_fst_NeqReturn)
    apply(erule seqE_cons)
    apply(simp add: seq'_cons)

    apply(simp) (*case a = AReturn*)

    apply(case_tac "matches γ m p")
    apply(simp add: matches_add_match_MatchNot_simp skip) (*the prems becomes useless in this case*)
    apply (metis decision skipD)

    (*case ¬ matches*)
    apply(simp add: not_matches_add_matchNot_simp) (*get IH*)
    by (metis decision state.exhaust nomatch seq'_cons)
qed simp

subsection@{const process_ret} correctness›
lemma process_ret_add_match_dist1: "Γ,γ,p process_ret (add_match m rs), s  t  Γ,γ,p add_match m (process_ret rs), s  t"
apply(induction rs arbitrary: s t)
 apply(simp add: add_match_def)
apply(rename_tac r rs s t)
apply(case_tac r)
apply(rename_tac m' a')
apply(simp)
apply(case_tac a')
        apply(simp_all add: add_match_split_fst)
        apply(erule seqE_cons)
        using seq' apply(fastforce)
       apply(erule seqE_cons)
       using seq' apply(fastforce)
      apply(erule seqE_cons)
      using seq' apply(fastforce)
     apply(erule seqE_cons)
     using seq' apply(fastforce)
    apply(erule seqE_cons)
    using seq' apply(fastforce)
   defer
   apply(erule seqE_cons)
   using seq' apply(fastforce)
  apply(erule seqE_cons)
  using seq' apply(fastforce)
 apply(case_tac "matches γ (MatchNot (MatchAnd m m')) p")
  apply(simp)
  apply (meson seq'_cons seqE_cons)
 apply (meson seq'_cons seqE_cons)
by (metis decision decisionD matches.simps(1) matches_add_match_MatchNot_simp matches_add_match_simp
  not_matches_add_matchNot_simp not_matches_add_match_simp state.exhaust)

lemma process_ret_add_match_dist2: "Γ,γ,p add_match m (process_ret rs), s  t  Γ,γ,p process_ret (add_match m rs), s  t"
apply(induction rs arbitrary: s t)
 apply(simp add: add_match_def)
apply(rename_tac r rs s t)
apply(case_tac r)
apply(rename_tac m' a')
apply(simp)
apply(case_tac a')
        apply(simp_all add: add_match_split_fst)
        apply(erule seqE_cons)
        using seq' apply(fastforce)
       apply(erule seqE_cons)
       using seq' apply(fastforce)
      apply(erule seqE_cons)
      using seq' apply(fastforce)
     apply(erule seqE_cons)
     using seq' apply(fastforce)
    apply(erule seqE_cons)
    using seq' apply(fastforce)
   defer
   apply(erule seqE_cons)
   using seq' apply(fastforce)
  apply(erule seqE_cons)
  using seq' apply(fastforce)
 apply(case_tac "matches γ (MatchNot (MatchAnd m m')) p")
  apply(simp)
  apply (meson seq'_cons seqE_cons)
 apply (meson seq'_cons seqE_cons)
by (metis decision decisionD matches.simps(1) matches_add_match_MatchNot_simp matches_add_match_simp
  not_matches_add_matchNot_simp not_matches_add_match_simp state.exhaust)

(*such fuckup*)
lemma process_ret_add_match_dist: "Γ,γ,p process_ret (add_match m rs), s  t  Γ,γ,p add_match m (process_ret rs), s  t"
by (metis process_ret_add_match_dist1 process_ret_add_match_dist2)


lemma process_ret_Undecided_sound:
  assumes "Γ(chain  rs),γ,p process_ret (add_match m rs), Undecided  Undecided"
  shows "Γ(chain  rs),γ,p [Rule m (Call chain)], Undecided  Undecided"
  proof (cases "matches γ m p")
    case False
    thus ?thesis
      by (metis nomatch)
  next
    case True
    note matches = this
    show ?thesis
      using assms proof (induction rs)
        case Nil
        from call_result[OF matches, where Γ="Γ(chain  [])"]
        have "(Γ(chain  [])) chain = Some []  Γ(chain  []),γ,p [], Undecided  Undecided  Γ(chain  []),γ,p [Rule m (Call chain)], Undecided  Undecided"
          by simp
        thus ?case
          by (fastforce intro: skip)
      next
        case (Cons r rs)
        obtain m' a' where r: "r = Rule m' a'" by (cases r) blast

        with Cons.prems have prems: "Γ(chain  Rule m' a' # rs),γ,p process_ret (add_match m (Rule m' a' # rs)), Undecided  Undecided"
          by fast
        hence prems_simplified: "Γ(chain  Rule m' a' # rs),γ,p process_ret (Rule m' a' # rs), Undecided  Undecided"
          using matches by (metis matches_add_match_simp process_ret_add_match_dist)

        have "Γ(chain  Rule m' a' # rs),γ,p [Rule m (Call chain)], Undecided  Undecided"
          proof (cases "a' = Return")
            case True
            note a' = this
            have "Γ(chain  Rule m' Return # rs),γ,p [Rule m (Call chain)], Undecided  Undecided"
              proof (cases "matches γ m' p")
                case True
                with matches show ?thesis
                  by (fastforce intro: call_return skip)
              next
                case False
                note matches' = this
                hence "Γ(chain  rs),γ,p process_ret (Rule m' a' # rs), Undecided  Undecided"
                  by (metis prems_simplified update_Gamma_nomatch)
                with a' have "Γ(chain  rs),γ,p add_match (MatchNot m') (process_ret rs), Undecided  Undecided"
                  by simp
                with matches matches' have "Γ(chain  rs),γ,p add_match m (process_ret rs), Undecided  Undecided" 
                  by (simp add: matches_add_match_simp not_matches_add_matchNot_simp)
                with matches' Cons.IH show ?thesis
                  by (fastforce simp: update_Gamma_nomatch process_ret_add_match_dist)
              qed
            with a' show ?thesis
              by simp
          next
            case False
            note a' = this
            with prems_simplified have "Γ(chain  Rule m' a' # rs),γ,p Rule m' a' # process_ret rs, Undecided  Undecided"
              by (simp add: process_ret_split_fst_NeqReturn)
            hence step: "Γ(chain  Rule m' a' # rs),γ,p [Rule m' a'], Undecided  Undecided"
            and   IH_pre: "Γ(chain  Rule m' a' # rs),γ,p process_ret rs, Undecided  Undecided"
              by (metis seqE_cons iptables_bigstep_to_undecided)+
            
            from step have "Γ(chain  rs),γ,p process_ret rs, Undecided  Undecided"
              proof (cases rule: Rule_UndecidedE)
                case log thus ?thesis
                  using IH_pre by (metis empty iptables_bigstep.log update_Gamma_nochange1 update_Gamma_nomatch)
              next
                case call thus ?thesis
                  using IH_pre by (metis update_Gamma_remove_call_undecided)
              next
                case nomatch thus ?thesis
                  using IH_pre by (metis update_Gamma_nomatch)
              qed

            hence "Γ(chain  rs),γ,p process_ret (add_match m rs), Undecided  Undecided"
              by (metis matches matches_add_match_simp process_ret_add_match_dist)
            with Cons.IH have IH: "Γ(chain  rs),γ,p [Rule m (Call chain)], Undecided  Undecided"
              by fast

            from step show ?thesis
              proof (cases rule: Rule_UndecidedE)
                case log thus ?thesis using IH
                   by (simp add: update_Gamma_log_empty)
              next
                case nomatch
                thus ?thesis
                  using IH by (metis update_Gamma_nomatch)
              next
                case (call c)
                let ?Γ' = "Γ(chain  Rule m' a' # rs)"
                from IH_pre show ?thesis
                  proof (cases rule: iptables_bigstep_process_ret_cases3)
                    case noreturn
                    with call have "?Γ',γ,p Rule m' (Call c) # rs, Undecided  Undecided"
                      by (metis step seq_cons)
                    from call have "?Γ' chain = Some (Rule m' (Call c) # rs)"
                      by simp
                    from matches show ?thesis
                      by (rule call_result) fact+
                  next
                    case (return rs1 rs2 new_m')
                    with call have "?Γ' chain = Some ((Rule m' (Call c) # rs1) @ [Rule new_m' Return] @ rs2)"
                      by simp
                    from call return step have "?Γ',γ,p Rule m' (Call c) # rs1, Undecided  Undecided"
                      using IH_pre by (auto intro: seq_cons)
                    from matches show ?thesis
                      by (rule call_return) fact+
                  qed
              qed
          qed
        thus ?case
          by (metis r)
      qed
  qed

lemma process_ret_Decision_sound:
  assumes "Γ(chain  rs),γ,p process_ret (add_match m rs), Undecided  Decision X"
  shows "Γ(chain  rs),γ,p [Rule m (Call chain)], Undecided  Decision X"
  proof (cases "matches γ m p")
    case False
    thus ?thesis by (metis assms state.distinct(1) not_matches_add_match_simp process_ret_add_match_dist1 skipD)
  next
    case True
    note matches = this
    show ?thesis
      using assms proof (induction rs)
        case Nil
        hence False by (metis add_match_split append_self_conv state.distinct(1) process_ret.simps(1) skipD)
        thus ?case by simp
      next
        case (Cons r rs)
        obtain m' a' where r: "r = Rule m' a'" by (cases r) blast

        with Cons.prems have prems: "Γ(chain  Rule m' a' # rs),γ,p process_ret (add_match m (Rule m' a' # rs)), Undecided  Decision X"
          by fast
        hence prems_simplified: "Γ(chain  Rule m' a' # rs),γ,p process_ret (Rule m' a' # rs), Undecided  Decision X"
          using matches by (metis matches_add_match_simp process_ret_add_match_dist)

        have "Γ(chain  Rule m' a' # rs),γ,p [Rule m (Call chain)], Undecided  Decision X"
          proof (cases "a' = Return")
            case True
            note a' = this
            have "Γ(chain  Rule m' Return # rs),γ,p [Rule m (Call chain)], Undecided  Decision X"
              proof (cases "matches γ m' p")
                case True
                with matches prems_simplified a' show ?thesis
                  by (auto simp: not_matches_add_match_simp dest: skipD)
              next
                case False
                note matches' = this
                with prems_simplified have "Γ(chain  rs),γ,p process_ret (Rule m' a' # rs), Undecided  Decision X"
                  by (metis update_Gamma_nomatch)
                with a' matches matches' have "Γ(chain  rs),γ,p add_match m (process_ret rs), Undecided  Decision X" 
                  by (simp add: matches_add_match_simp not_matches_add_matchNot_simp)
                with matches matches' Cons.IH show ?thesis
                  by (fastforce simp: update_Gamma_nomatch process_ret_add_match_dist matches_add_match_simp not_matches_add_matchNot_simp)
              qed
            with a' show ?thesis
              by simp
          next
            case False
            with prems_simplified obtain ti
              where step: "Γ(chain  Rule m' a' # rs),γ,p [Rule m' a'], Undecided  ti"
                and IH_pre: "Γ(chain  Rule m' a' # rs),γ,p process_ret rs, ti  Decision X"
              by (auto simp: process_ret_split_fst_NeqReturn elim: seqE_cons)

            hence "Γ(chain  Rule m' a' # rs),γ,p rs, ti  Decision X"
              by (metis iptables_bigstep_process_ret_DecisionD)

            thus ?thesis
              using matches step by (force intro: call_result seq'_cons)
          qed
        thus ?case
          by (metis r)
      qed
  qed

lemma process_ret_result_empty: "[] = process_ret rs  r  set rs. get_action r = Return"
  proof (induction rs)
    case (Cons r rs)
    thus ?case
      apply(simp)
      apply(case_tac r)
      apply(rename_tac m a)
      apply(case_tac a)
              apply(simp_all add: add_match_def)
      done
  qed simp


lemma process_ret_sound':
  assumes "Γ(chain  rs),γ,p process_ret (add_match m rs), Undecided  t"
  shows "Γ(chain  rs),γ,p [Rule m (Call chain)], Undecided  t"
using assms by (metis state.exhaust process_ret_Undecided_sound process_ret_Decision_sound)



lemma wf_chain_process_ret: "wf_chain Γ rs  wf_chain Γ (process_ret rs)"
  apply(induction rs)
  apply(simp add: wf_chain_def add_match_def)
  apply(case_tac a)
  apply(case_tac "x2  Return")
   apply(simp add: process_ret_split_fst_NeqReturn)
   using wf_chain_append apply (metis Cons_eq_appendI append_Nil)
  apply(simp add: process_ret_split_fst_Return)
  apply(simp add: wf_chain_def add_match_def get_action_case_simp)
  done
lemma wf_chain_add_match: "wf_chain Γ rs  wf_chain Γ (add_match m rs)"
  by(induction rs) (simp_all add: wf_chain_def add_match_def get_action_case_simp)

subsection‹Soundness›
theorem unfolding_sound: "wf_chain Γ rs  Γ,γ,p process_call Γ rs, s  t  Γ,γ,p rs, s  t"
proof (induction rs arbitrary: s t)
  case (Cons r rs)
  thus ?case
    apply -
    apply(subst(asm) process_call_split_fst)
    apply(erule seqE)

    unfolding wf_chain_def
    apply(case_tac r, rename_tac m a)
    apply(case_tac a)
            apply(simp_all add: seq'_cons)

    apply(case_tac s)
     defer
     apply (metis decision decisionD)
    apply(case_tac "matches γ m p")
     defer
     apply(simp add: not_matches_add_match_simp)
     apply(drule skipD, simp)
     apply (metis nomatch seq_cons)
    apply(clarify)
    apply(simp add: matches_add_match_simp)
    apply(rule_tac t=ti in seq_cons)
     apply(simp_all)

    using process_ret_sound'
    by (metis fun_upd_triv matches_add_match_simp process_ret_add_match_dist)
qed simp

corollary unfolding_sound_complete: "wf_chain Γ rs  Γ,γ,p process_call Γ rs, s  t  Γ,γ,p rs, s  t"
by (metis unfolding_complete unfolding_sound)

corollary unfolding_n_sound_complete: "rsg  ran Γ  {rs}. wf_chain Γ rsg  Γ,γ,p ((process_call Γ)^^n) rs, s  t  Γ,γ,p rs, s  t"
  proof(induction n arbitrary: rs)
    case 0 thus ?case by simp
  next
    case (Suc n)
      from Suc have "Γ,γ,p (process_call Γ ^^ n) rs, s  t = Γ,γ,p rs, s  t" by blast
      from Suc.prems have "aran Γ  {process_call Γ rs}. wf_chain Γ a"
        proof(induction rs)
          case Nil thus ?case by simp
        next
          case(Cons r rs)
            from Cons.prems have "aran Γ. wf_chain Γ a" by blast
            from Cons.prems have "wf_chain Γ [r]"
              apply(simp)
              apply(clarify)
              apply(simp add: wf_chain_def)
              done
            from Cons.prems have "wf_chain Γ rs"
              apply(simp)
              apply(clarify)
              apply(simp add: wf_chain_def)
              done
            from this Cons.prems Cons.IH have "wf_chain Γ (process_call Γ rs)" by blast
            from this ‹wf_chain Γ [r]have "wf_chain Γ (r # (process_call Γ rs))" by(simp add: wf_chain_def)
            from this Cons.prems have "wf_chain Γ (process_call Γ (r#rs))"
              apply(cases r)
              apply(rename_tac m a, clarify)
              apply(case_tac a)
                      apply(simp_all)
              apply(simp add: wf_chain_append)
              apply(clarify)
              apply(simp add: ‹wf_chain Γ (process_call Γ rs))
              apply(rule wf_chain_add_match)
              apply(rule wf_chain_process_ret)
              apply(simp add: wf_chain_def)
              apply(clarify)
              by (metis ranI option.sel)
          from this aran Γ. wf_chain Γ a show ?case by simp
        qed
      from this Suc.IH[of "((process_call Γ) rs)"] have 
        "Γ,γ,p (process_call Γ ^^ n) (process_call Γ rs), s  t = Γ,γ,p process_call Γ rs, s  t"
        by simp
    from this show ?case by (simp add: Suc.prems funpow_swap1 unfolding_sound_complete)
  qed


text_raw‹
\begin{verbatim}
loops in the linux kernel:
http://lxr.linux.no/linux+v3.2/net/ipv4/netfilter/ip_tables.c#L464
/* Figures out from what hook each rule can be called: returns 0 if
   there are loops.  Puts hook bitmask in comefrom. */
   static int mark_source_chains(const struct xt_table_info *newinfo,
                   unsigned int valid_hooks, void *entry0)

discussion: http://marc.info/?l=netfilter-devel&m=105190848425334&w=2
\end{verbatim}
›

text‹Example›
lemma "process_call [''X''  [Rule (Match b) Return, Rule (Match c) Accept]] [Rule (Match a) (Call ''X'')] =
       [Rule (MatchAnd (Match a) (MatchAnd (MatchNot (Match b)) (Match c))) Accept]" by (simp add: add_match_def)




text‹This is how a firewall processes a ruleset. 
       It starts at a certain chain, usually INPUT, FORWARD, or OUTPUT (called @{term chain_name} in the lemma).
       The firewall has a default action of accept or drop.
      We can check @{const sanity_wf_ruleset} and the other assumptions at runtime.
      Consequently, we can apply @{const repeat_stabilize} as often as we want.
›

theorem repeat_stabilize_process_call:
    assumes "sanity_wf_ruleset Γ" and "chain_name  set (map fst Γ)" and "default_action = Accept  default_action = Drop"
    shows "(map_of Γ),γ,p repeat_stabilize n (process_call (map_of Γ)) [Rule MatchAny (Call chain_name), Rule MatchAny default_action], s  t 
           (map_of Γ),γ,p [Rule MatchAny (Call chain_name), Rule MatchAny default_action], s  t"
proof -
  have x: "sanity_wf_ruleset Γ  rs  ran (map_of Γ)  wf_chain (map_of Γ) rs" for Γ and rs::"'a rule list"
  apply(simp add: sanity_wf_ruleset_def wf_chain_def)
  by fastforce

  from assms(1) have 1: "rsg  ran (map_of Γ). wf_chain (map_of Γ) rsg"
    apply(intro ballI)
    apply(drule x, simp)
    apply(simp)
    done
  let ?rs="[Rule MatchAny (Call chain_name), Rule MatchAny default_action]::'a rule list"
  from assms(2,3) have 2: "wf_chain (map_of Γ) ?rs"
    apply(simp add: wf_chain_def domD dom_map_of_conv_image_fst)
    by blast

  have "rsg  ran Γ  {rs}. wf_chain Γ rsg  
    Γ,γ,p repeat_stabilize n (process_call Γ) rs, s  t  Γ,γ,p rs, s  t" for Γ rs
  by(simp add: repeat_stabilize_funpow unfolding_n_sound_complete)
  moreover from 1 2 have "rsg  ran (map_of Γ)  {?rs}. wf_chain (map_of Γ) rsg" by simp
  ultimately show ?thesis by simp
qed



definition unfold_optimize_ruleset_CHAIN
  :: "('a match_expr  'a match_expr)  string  action  'a ruleset  'a rule list option"
where
"unfold_optimize_ruleset_CHAIN optimize chain_name default_action rs = (let rs =
  (repeat_stabilize 1000 (optimize_matches opt_MatchAny_match_expr)
    (optimize_matches optimize
      (rw_Reject (rm_LogEmpty (repeat_stabilize 10000 (process_call rs)
        [Rule MatchAny (Call chain_name), Rule MatchAny default_action]
  )))))
  in if simple_ruleset rs then Some rs else None)"


lemma unfold_optimize_ruleset_CHAIN:
    assumes "sanity_wf_ruleset Γ" and "chain_name  set (map fst Γ)"
    and "default_action = Accept  default_action = Drop"
    and "m. matches γ (optimize m) p = matches γ m p"
    and "unfold_optimize_ruleset_CHAIN optimize chain_name default_action (map_of Γ) = Some rs"
    shows "(map_of Γ),γ,p rs, s  t 
           (map_of Γ),γ,p [Rule MatchAny (Call chain_name), Rule MatchAny default_action], s  t"
proof -
  from assms(5) have rs: "rs = repeat_stabilize 1000 (optimize_matches opt_MatchAny_match_expr)
      (optimize_matches optimize
        (rw_Reject
          (rm_LogEmpty
            (repeat_stabilize 10000 (process_call (map_of Γ)) [Rule MatchAny (Call chain_name), Rule MatchAny default_action]))))"
    by(simp add: unfold_optimize_ruleset_CHAIN_def Let_def split: if_split_asm)

  have optimize_matches_generic_funpow_helper: "(m. matches γ (f m) p = matches γ m p) 
        Γ,γ,p (optimize_matches f ^^ n) rs, s  t  Γ,γ,p rs, s  t"
    for Γ f n rs
    proof(induction n arbitrary:)
      case 0 thus ?case by simp
    next
      case (Suc n) thus ?case
       apply(simp)
       apply(subst optimize_matches_generic[where P="λ_. True"])
       by simp_all
    qed

  have "(map_of Γ),γ,p rs, s  t  map_of Γ,γ,p repeat_stabilize 10000 (process_call (map_of Γ))
    [Rule MatchAny (Call chain_name), Rule MatchAny default_action], s  t"
    apply(simp add: rs repeat_stabilize_funpow)
    apply(subst optimize_matches_generic_funpow_helper)
     apply (simp add: opt_MatchAny_match_expr_correct; fail)
    apply(subst optimize_matches_generic[where P="λ_. True"], simp_all add: assms(4))
    apply(simp add: iptables_bigstep_rw_Reject iptables_bigstep_rm_LogEmpty)
    done
  also have "  (map_of Γ),γ,p [Rule MatchAny (Call chain_name), Rule MatchAny default_action], s  t"
    using assms(1,2,3) by(intro repeat_stabilize_process_call[of Γ chain_name default_action γ p 10000 s t]) simp_all
  finally show ?thesis .
qed

end

Theory Ternary

section‹Ternary Logic›
theory Ternary
imports Main
begin

text‹Kleene logic›

datatype ternaryvalue = TernaryTrue | TernaryFalse | TernaryUnknown
datatype ternaryformula = TernaryAnd ternaryformula ternaryformula
                        | TernaryOr ternaryformula ternaryformula
                        | TernaryNot ternaryformula
                        | TernaryValue ternaryvalue

fun ternary_to_bool :: "ternaryvalue  bool option" where
  "ternary_to_bool TernaryTrue = Some True" |
  "ternary_to_bool TernaryFalse = Some False" |
  "ternary_to_bool TernaryUnknown = None"

fun bool_to_ternary :: "bool  ternaryvalue" where
  "bool_to_ternary True = TernaryTrue" |
  "bool_to_ternary False = TernaryFalse"


lemma "the  ternary_to_bool  bool_to_ternary = id"
  by(simp add: fun_eq_iff, clarify, case_tac x, simp_all)
lemma ternary_to_bool_bool_to_ternary: "ternary_to_bool (bool_to_ternary X) = Some X"
by(cases X, simp_all)
lemma ternary_to_bool_None: "ternary_to_bool t = None  t = TernaryUnknown"
  by(cases t, simp_all)
lemma ternary_to_bool_SomeE: "ternary_to_bool t = Some X 
  (t = TernaryTrue  X = True  P)  (t = TernaryFalse  X = False  P)   P"
  by(cases t)(simp)+
lemma ternary_to_bool_Some: "ternary_to_bool t = Some X 
  (t = TernaryTrue  X = True)  (t = TernaryFalse  X = False)"
  by(cases t, simp_all)
lemma bool_to_ternary_Unknown: "bool_to_ternary t = TernaryUnknown  False"
by(cases t, simp_all)


fun eval_ternary_And :: "ternaryvalue  ternaryvalue  ternaryvalue" where
  "eval_ternary_And TernaryTrue TernaryTrue = TernaryTrue" |
  "eval_ternary_And TernaryTrue TernaryFalse = TernaryFalse" |
  "eval_ternary_And TernaryFalse TernaryTrue = TernaryFalse" |
  "eval_ternary_And TernaryFalse TernaryFalse = TernaryFalse" |
  "eval_ternary_And TernaryFalse TernaryUnknown = TernaryFalse" |
  "eval_ternary_And TernaryTrue TernaryUnknown = TernaryUnknown" |
  "eval_ternary_And TernaryUnknown TernaryFalse = TernaryFalse" |
  "eval_ternary_And TernaryUnknown TernaryTrue = TernaryUnknown"  |
  "eval_ternary_And TernaryUnknown TernaryUnknown = TernaryUnknown" 

lemma eval_ternary_And_comm: "eval_ternary_And t1 t2 = eval_ternary_And t2 t1"
  by (cases t1 t2 rule: ternaryvalue.exhaust[case_product ternaryvalue.exhaust]) auto

fun eval_ternary_Or :: "ternaryvalue  ternaryvalue  ternaryvalue" where
  "eval_ternary_Or TernaryTrue TernaryTrue = TernaryTrue" |
  "eval_ternary_Or TernaryTrue TernaryFalse = TernaryTrue" |
  "eval_ternary_Or TernaryFalse TernaryTrue = TernaryTrue" |
  "eval_ternary_Or TernaryFalse TernaryFalse = TernaryFalse" |
  "eval_ternary_Or TernaryTrue TernaryUnknown = TernaryTrue" | 
  "eval_ternary_Or TernaryFalse TernaryUnknown = TernaryUnknown" | 
  "eval_ternary_Or TernaryUnknown TernaryTrue = TernaryTrue" | 
  "eval_ternary_Or TernaryUnknown TernaryFalse = TernaryUnknown" | 
  "eval_ternary_Or TernaryUnknown TernaryUnknown = TernaryUnknown"

fun eval_ternary_Not :: "ternaryvalue   ternaryvalue" where
  "eval_ternary_Not TernaryTrue = TernaryFalse" |
  "eval_ternary_Not TernaryFalse = TernaryTrue" |
  "eval_ternary_Not TernaryUnknown = TernaryUnknown"


text‹Just to hint that we did not make a typo, we add the truth table for
      the implication and show that it is compliant with @{term "a  b  ¬a  b"}
fun eval_ternary_Imp :: "ternaryvalue  ternaryvalue  ternaryvalue" where
  "eval_ternary_Imp TernaryTrue TernaryTrue = TernaryTrue" |
  "eval_ternary_Imp TernaryTrue TernaryFalse = TernaryFalse" |
  "eval_ternary_Imp TernaryFalse TernaryTrue = TernaryTrue" |
  "eval_ternary_Imp TernaryFalse TernaryFalse = TernaryTrue" |
  "eval_ternary_Imp TernaryTrue TernaryUnknown = TernaryUnknown" | 
  "eval_ternary_Imp TernaryFalse TernaryUnknown = TernaryTrue" | 
  "eval_ternary_Imp TernaryUnknown TernaryTrue = TernaryTrue" | 
  "eval_ternary_Imp TernaryUnknown TernaryFalse = TernaryUnknown" | 
  "eval_ternary_Imp TernaryUnknown TernaryUnknown = TernaryUnknown"
lemma "eval_ternary_Imp a b = eval_ternary_Or (eval_ternary_Not a) b"
apply(cases a)
  apply(case_tac [!] b)
        apply(simp_all)
done



lemma eval_ternary_Not_UnknownD: "eval_ternary_Not t = TernaryUnknown  t = TernaryUnknown"
  by (cases t) auto

lemma eval_ternary_DeMorgan:
  "eval_ternary_Not (eval_ternary_And a b) = eval_ternary_Or (eval_ternary_Not a) (eval_ternary_Not b)"
  "eval_ternary_Not (eval_ternary_Or a b) = eval_ternary_And (eval_ternary_Not a) (eval_ternary_Not b)"
  by (cases a b rule: ternaryvalue.exhaust[case_product ternaryvalue.exhaust],auto)+

lemma eval_ternary_idempotence_Not: "eval_ternary_Not (eval_ternary_Not a) = a"
  by (cases a) simp_all


lemma eval_ternary_simps_simple: 
  "eval_ternary_And TernaryTrue x = x"
  "eval_ternary_And x TernaryTrue = x"
  "eval_ternary_And TernaryFalse x = TernaryFalse"
  "eval_ternary_And x TernaryFalse = TernaryFalse"
  by(case_tac [!] x)(simp_all)


context
begin
  private lemma bool_to_ternary_simp1: "bool_to_ternary X = TernaryTrue  X"
    by (metis bool_to_ternary.elims ternaryvalue.distinct(1))
  private lemma bool_to_ternary_simp2:  "bool_to_ternary Y = TernaryFalse  ¬ Y"
    by (metis bool_to_ternary.elims ternaryvalue.distinct(1))
  private lemma bool_to_ternary_simp3: "eval_ternary_Not (bool_to_ternary X) = TernaryTrue  ¬ X"
    by (metis (full_types) bool_to_ternary_simp2 eval_ternary_Not.simps(1) eval_ternary_idempotence_Not)
  private lemma bool_to_ternary_simp4: "eval_ternary_Not (bool_to_ternary X) = TernaryFalse  X"
    by (metis bool_to_ternary_simp1 eval_ternary_Not.simps(1) eval_ternary_idempotence_Not)
  private lemma bool_to_ternary_simp5: "¬ (eval_ternary_Not (bool_to_ternary X) = TernaryUnknown)"
    by (metis bool_to_ternary_Unknown eval_ternary_Not_UnknownD)

  private lemma bool_to_ternary_simp6: "bool_to_ternary X  TernaryUnknown"
    by (metis (full_types) bool_to_ternary.simps(1) bool_to_ternary.simps(2) ternaryvalue.distinct(3) ternaryvalue.distinct(5))

  lemmas bool_to_ternary_simps = bool_to_ternary_simp1 bool_to_ternary_simp2
                                 bool_to_ternary_simp3 bool_to_ternary_simp4
                                 bool_to_ternary_simp5 bool_to_ternary_simp6
end

context
begin
  private lemma bool_to_ternary_pullup1:
    "eval_ternary_Not (bool_to_ternary X) = bool_to_ternary (¬ X)"
    by(cases X)(simp_all)
  
  private lemma bool_to_ternary_pullup2:
    "eval_ternary_And (bool_to_ternary X1) (bool_to_ternary X2) = bool_to_ternary (X1  X2)"
    by (metis bool_to_ternary_simps(1) bool_to_ternary_simps(2) eval_ternary_simps_simple(2) eval_ternary_simps_simple(4))

  private lemma bool_to_ternary_pullup3:
    "eval_ternary_Imp (bool_to_ternary X1) (bool_to_ternary X2) = bool_to_ternary (X1  X2)"
    by (metis bool_to_ternary_simps(1) bool_to_ternary_simps(2) eval_ternary_Imp.simps(1) 
        eval_ternary_Imp.simps(2) eval_ternary_Imp.simps(3) eval_ternary_Imp.simps(4))
    
  private lemma bool_to_ternary_pullup4:
    "eval_ternary_Or (bool_to_ternary X1) (bool_to_ternary X2) = bool_to_ternary (X1  X2)"
    by (metis (full_types) bool_to_ternary.simps(1) bool_to_ternary.simps(2) eval_ternary_Or.simps(1) eval_ternary_Or.simps(2) eval_ternary_Or.simps(3) eval_ternary_Or.simps(4))  
  
  lemmas bool_to_ternary_pullup = bool_to_ternary_pullup1 bool_to_ternary_pullup2
                                  bool_to_ternary_pullup3 bool_to_ternary_pullup4
end



fun ternary_ternary_eval :: "ternaryformula  ternaryvalue" where
  "ternary_ternary_eval (TernaryAnd t1 t2) = eval_ternary_And (ternary_ternary_eval t1) (ternary_ternary_eval t2)" |
  "ternary_ternary_eval (TernaryOr t1 t2) = eval_ternary_Or (ternary_ternary_eval t1) (ternary_ternary_eval t2)" |
  "ternary_ternary_eval (TernaryNot t) = eval_ternary_Not (ternary_ternary_eval t)" |
  "ternary_ternary_eval (TernaryValue t) = t"

lemma ternary_ternary_eval_DeMorgan: "ternary_ternary_eval (TernaryNot (TernaryAnd a b)) = 
    ternary_ternary_eval (TernaryOr (TernaryNot a) (TernaryNot b))"
by (simp add: eval_ternary_DeMorgan)

lemma ternary_ternary_eval_idempotence_Not:
  "ternary_ternary_eval (TernaryNot (TernaryNot a)) = ternary_ternary_eval a"
by (simp add: eval_ternary_idempotence_Not)

lemma ternary_ternary_eval_TernaryAnd_comm:
  "ternary_ternary_eval (TernaryAnd t1 t2) = ternary_ternary_eval (TernaryAnd t2 t1)"
by (simp add: eval_ternary_And_comm)

lemma "eval_ternary_Not (ternary_ternary_eval t) = (ternary_ternary_eval (TernaryNot t))" by simp


context
begin
  private lemma eval_ternary_simps_2:
      "eval_ternary_And (bool_to_ternary P) T = TernaryTrue  P  T = TernaryTrue"
      "eval_ternary_And T (bool_to_ternary P) = TernaryTrue  P  T = TernaryTrue"
  apply(case_tac [!] P)
     apply(simp_all add: eval_ternary_simps_simple)
  done

  private lemma eval_ternary_simps_3:
      "eval_ternary_And (ternary_ternary_eval x) T = TernaryTrue 
        ternary_ternary_eval x = TernaryTrue  T = TernaryTrue"
      "eval_ternary_And T (ternary_ternary_eval x) = TernaryTrue 
        ternary_ternary_eval x = TernaryTrue  T = TernaryTrue"
  apply(case_tac [!] T)
       apply(simp_all add: eval_ternary_simps_simple)
   apply(case_tac [!] "(ternary_ternary_eval x)")
       apply(simp_all)
  done

  lemmas eval_ternary_simps = eval_ternary_simps_simple eval_ternary_simps_2 eval_ternary_simps_3
end

definition ternary_eval :: "ternaryformula  bool option" where
  "ternary_eval t = ternary_to_bool (ternary_ternary_eval t)"

subsection‹Negation Normal Form›

text‹A formula is in Negation Normal Form (NNF) if negations only occur at the atoms (not before and/or)›
inductive NegationNormalForm :: "ternaryformula  bool" where
  "NegationNormalForm (TernaryValue v)" |
  "NegationNormalForm (TernaryNot (TernaryValue v))" |
  "NegationNormalForm φ  NegationNormalForm ψ  NegationNormalForm (TernaryAnd φ ψ)"|
  "NegationNormalForm φ  NegationNormalForm ψ  NegationNormalForm (TernaryOr φ ψ)"

text‹Convert a @{typ ternaryformula} to a  @{typ ternaryformula} in NNF.›
fun NNF_ternary :: "ternaryformula  ternaryformula" where
  "NNF_ternary (TernaryValue v) = TernaryValue v" |
  "NNF_ternary (TernaryAnd t1 t2) = TernaryAnd (NNF_ternary t1) (NNF_ternary t2)" |
  "NNF_ternary (TernaryOr t1 t2) = TernaryOr (NNF_ternary t1) (NNF_ternary t2)" |
  "NNF_ternary (TernaryNot (TernaryNot t)) = NNF_ternary t" |
  "NNF_ternary (TernaryNot (TernaryValue v)) = TernaryValue (eval_ternary_Not v)" |
  "NNF_ternary (TernaryNot (TernaryAnd t1 t2)) = TernaryOr (NNF_ternary (TernaryNot t1)) (NNF_ternary (TernaryNot t2))" |
  "NNF_ternary (TernaryNot (TernaryOr t1 t2)) = TernaryAnd (NNF_ternary (TernaryNot t1)) (NNF_ternary (TernaryNot t2))"


lemma NNF_ternary_correct: "ternary_ternary_eval (NNF_ternary t) = ternary_ternary_eval t"
  proof(induction t rule: NNF_ternary.induct)
  qed(simp_all add: eval_ternary_DeMorgan eval_ternary_idempotence_Not)

lemma NNF_ternary_NegationNormalForm: "NegationNormalForm (NNF_ternary t)"
  proof(induction t rule: NNF_ternary.induct)
  qed(auto simp add: eval_ternary_DeMorgan eval_ternary_idempotence_Not intro: NegationNormalForm.intros)




context
begin
  private lemma ternary_lift1: "eval_ternary_Not tv  TernaryFalse  tv = TernaryFalse  tv = TernaryUnknown"
    using eval_ternary_Not.elims by blast
  private lemma ternary_lift2: "eval_ternary_Not tv  TernaryTrue  tv = TernaryTrue  tv = TernaryUnknown"
    using eval_ternary_Not.elims by blast
  private lemma ternary_lift3: "eval_ternary_Not tv = TernaryFalse  tv = TernaryTrue"
    by (metis eval_ternary_Not.simps(1) eval_ternary_idempotence_Not)
  private lemma ternary_lift4: "eval_ternary_Not tv = TernaryTrue  tv = TernaryFalse"
    by (metis eval_ternary_Not.simps(1) eval_ternary_idempotence_Not)
  private lemma ternary_lift5: "eval_ternary_Not tv = TernaryUnknown  tv = TernaryUnknown"
    by (metis eval_ternary_Not.simps(3) eval_ternary_idempotence_Not)

  private lemma ternary_lift6: "eval_ternary_And t1 t2 = TernaryFalse  t1 = TernaryFalse  t2 = TernaryFalse"
    using eval_ternary_And.elims by blast
  private lemma ternary_lift7: "eval_ternary_And t1 t2 = TernaryTrue  t1 = TernaryTrue  t2 = TernaryTrue"
    using eval_ternary_And.elims by blast

  lemmas ternary_lift = ternary_lift1 ternary_lift2 ternary_lift3 ternary_lift4 ternary_lift5 ternary_lift6 ternary_lift7
end

context
begin
  private lemma l1: "eval_ternary_Not tv = TernaryTrue  tv = TernaryFalse"
    by (metis eval_ternary_Not.simps(1) eval_ternary_idempotence_Not)
  private lemma l2: "eval_ternary_And t1 t2 = TernaryFalse  t1 = TernaryFalse  t2 = TernaryFalse"
    using eval_ternary_And.elims by blast
  
  lemmas eval_ternaryD = l1 l2
end

end

Theory Matching_Ternary

theory Matching_Ternary
imports "../Common/Ternary" "../Firewall_Common"
begin


section‹Packet Matching in Ternary Logic›

text‹The matcher for a primitive match expression @{typ "'a"}
type_synonym ('a, 'packet) exact_match_tac="'a  'packet  ternaryvalue"

text‹
If the matching is @{const TernaryUnknown}, it can be decided by the action whether this rule matches.
E.g. in doubt, we allow packets
›
type_synonym 'packet unknown_match_tac="action  'packet  bool"

type_synonym ('a, 'packet) match_tac="(('a, 'packet) exact_match_tac × 'packet unknown_match_tac)"

text‹
For a given packet, map a firewall @{typ "'a match_expr"} to a @{typ ternaryformula}
Evaluating the formula gives whether the packet/rule matches (or unknown).
›
fun map_match_tac :: "('a, 'packet) exact_match_tac  'packet  'a match_expr  ternaryformula" where
  "map_match_tac β p (MatchAnd m1 m2) = TernaryAnd (map_match_tac β p m1) (map_match_tac β p m2)" |
  "map_match_tac β p (MatchNot m) = TernaryNot (map_match_tac β p m)" |
  "map_match_tac β p (Match m) = TernaryValue (β m p)" |
  "map_match_tac _ _ MatchAny = TernaryValue TernaryTrue"


context
begin
  text‹the @{term ternaryformula}s we construct never have Or expressions.›
  private fun ternary_has_or :: "ternaryformula  bool" where
    "ternary_has_or (TernaryOr _ _)  True" |
    "ternary_has_or (TernaryAnd t1 t2)  ternary_has_or t1  ternary_has_or t2" |
    "ternary_has_or (TernaryNot t)  ternary_has_or t" |
    "ternary_has_or (TernaryValue _)  False"
  private lemma map_match_tac__does_not_use_TernaryOr: "¬ (ternary_has_or (map_match_tac β p m))"
    by(induction m, simp_all)
  declare ternary_has_or.simps[simp del]
end


fun ternary_to_bool_unknown_match_tac :: "'packet unknown_match_tac  action  'packet  ternaryvalue  bool" where
  "ternary_to_bool_unknown_match_tac _ _ _ TernaryTrue = True" |
  "ternary_to_bool_unknown_match_tac _ _ _ TernaryFalse = False" |
  "ternary_to_bool_unknown_match_tac α a p TernaryUnknown = α a p"

text‹
Matching a packet and a rule:
\begin{enumerate}
  \item Translate @{typ "'a match_expr"} to ternary formula
  \item Evaluate this formula
  \item If @{const TernaryTrue}/@{const TernaryFalse}, return this value
  \item If @{const TernaryUnknown}, apply the @{typ "'a unknown_match_tac"} to get a Boolean result
\end{enumerate}
›
definition matches :: "('a, 'packet) match_tac  'a match_expr  action  'packet  bool" where
  "matches γ m a p  ternary_to_bool_unknown_match_tac (snd γ) a p (ternary_ternary_eval (map_match_tac (fst γ) p m))"


text‹Alternative matches definitions, some more or less convenient›

lemma matches_tuple: "matches (β, α) m a p = ternary_to_bool_unknown_match_tac α a p (ternary_ternary_eval (map_match_tac β p m))"
unfolding matches_def by simp

lemma matches_case: "matches γ m a p  (case ternary_eval (map_match_tac (fst γ) p m) of None  (snd γ) a p | Some b  b)"
unfolding matches_def ternary_eval_def
by (cases "(ternary_ternary_eval (map_match_tac (fst γ) p m))") auto

lemma matches_case_tuple: "matches (β, α) m a p  (case ternary_eval (map_match_tac β p m) of None  α a p | Some b  b)"
by (auto simp: matches_case split: option.splits)

lemma matches_case_ternaryvalue_tuple: "matches (β, α) m a p  (case ternary_ternary_eval (map_match_tac β p m) of 
        TernaryUnknown  α a p | 
        TernaryTrue  True |
        TernaryFalse  False)"
  by(simp split: option.split ternaryvalue.split add: matches_case ternary_to_bool_None ternary_eval_def)
(*use together: matches_case_ternaryvalue_tuple ternaryvalue.split *)


lemma matches_casesE:
  "matches (β, α) m a p  
    (ternary_ternary_eval (map_match_tac β p m) = TernaryUnknown  α a p  P)  
    (ternary_ternary_eval (map_match_tac β p m) = TernaryTrue  P)
   P"
proof(induction m)
qed(auto split: option.split_asm simp: matches_case_tuple ternary_eval_def ternary_to_bool_bool_to_ternary elim: ternary_to_bool.elims)


text‹
Example: ¬ Unknown› is as good as Unknown›
lemma " ternary_ternary_eval (map_match_tac β p expr) = TernaryUnknown   matches (β, α) expr a p  matches (β, α) (MatchNot expr) a p"
by(simp add: matches_case_ternaryvalue_tuple)


lemma bunch_of_lemmata_about_matches:
  "matches γ (MatchAnd m1 m2) a p  matches γ m1 a p  matches γ m2 a p" (*split AND*)
  "matches γ MatchAny a p" (*MatchAny is True*)
  "matches γ (MatchNot MatchAny) a p  False" (*Not True*)
  "matches γ (MatchNot (MatchNot m)) a p  matches γ m a p" (*idempotence*)
proof(case_tac [!] γ)
qed (simp_all split: ternaryvalue.split add: matches_case_ternaryvalue_tuple)

lemma match_raw_bool:
  "matches (β, α) (Match expr) a p = (case ternary_to_bool (β expr p) of Some r  r | None  (α a p))" (*Match raw*)
by(simp_all split: ternaryvalue.split add: matches_case_ternaryvalue_tuple)
lemma match_raw_ternary:
  "matches (β, α) (Match expr) a p = (case (β expr p) of TernaryTrue  True | TernaryFalse  False | TernaryUnknown  (α a p))" (*Match raw explicit*)
by(simp_all split: ternaryvalue.split add: matches_case_ternaryvalue_tuple)

(*kind of the DeMorgan Rule for matches*)
lemma matches_DeMorgan: "matches γ (MatchNot (MatchAnd m1 m2)) a p  (matches γ (MatchNot m1) a p)  (matches γ (MatchNot m2) a p)"
by (cases γ) (simp split: ternaryvalue.split add: matches_case_ternaryvalue_tuple eval_ternary_DeMorgan)


subsection‹Ternary Matcher Algebra›

lemma matches_and_comm: "matches γ (MatchAnd m m') a p  matches γ (MatchAnd m' m) a p"
apply(cases γ, rename_tac β α, clarify)
by(simp add: matches_case_ternaryvalue_tuple eval_ternary_And_comm)

lemma matches_not_idem: "matches γ (MatchNot (MatchNot m)) a p  matches γ m a p"
by (fact bunch_of_lemmata_about_matches)


lemma MatchOr: "matches γ (MatchOr m1 m2) a p  matches γ m1 a p  matches γ m2 a p"
  by(simp add: MatchOr_def matches_DeMorgan matches_not_idem)

lemma MatchOr_MatchNot: "matches γ (MatchNot (MatchOr m1 m2)) a p  matches γ (MatchNot m1) a p  matches γ (MatchNot m2) a p"
  by(simp add: MatchOr_def matches_DeMorgan bunch_of_lemmata_about_matches)


lemma "(TernaryNot (map_match_tac β p (m))) = (map_match_tac β p (MatchNot m))"
by (metis map_match_tac.simps(2))

context
begin
  private lemma matches_simp1: "matches γ m a p  matches γ (MatchAnd m m') a p  matches γ m' a p"
    apply(cases γ, rename_tac β α, clarify)
    apply(simp split: ternaryvalue.split_asm ternaryvalue.split add: matches_case_ternaryvalue_tuple)
    done
  
  private lemma matches_simp11: "matches γ m a p  matches γ (MatchAnd m' m) a p  matches γ m' a p"
    by(simp_all add: matches_and_comm matches_simp1)
  
  private lemma matches_simp2: "matches γ (MatchAnd m m') a p  ¬ matches γ m a p  False"
    by (simp add: bunch_of_lemmata_about_matches)
  private lemma matches_simp22: "matches γ (MatchAnd m m') a p  ¬ matches γ m' a p  False"
    by (simp add: bunch_of_lemmata_about_matches)
  
  (*m simplifies to MatchUnknown*)
 private  lemma matches_simp3: "matches γ (MatchNot m) a p  matches γ m a p  (snd γ) a p"
    apply(cases γ, rename_tac β α, clarify)
    apply(simp split: ternaryvalue.split_asm ternaryvalue.split add: matches_case_ternaryvalue_tuple)
    done
  private lemma "matches γ (MatchNot m) a p  matches γ m a p  (ternary_eval (map_match_tac (fst γ) p m)) = None"
    apply(cases γ, rename_tac β α, clarify)
    apply(simp split: ternaryvalue.split_asm ternaryvalue.split add: matches_case_ternaryvalue_tuple ternary_eval_def)
    done
  
  lemmas matches_simps = matches_simp1 matches_simp11
  lemmas matches_dest = matches_simp2 matches_simp22
end


lemma matches_iff_apply_f_generic: "ternary_ternary_eval (map_match_tac β p (f (β,α) a m)) = ternary_ternary_eval (map_match_tac β p m)  matches (β,α) (f (β,α) a m) a p  matches (β,α) m a p"
  by(simp split: ternaryvalue.split_asm ternaryvalue.split add: matches_case_ternaryvalue_tuple)

lemma matches_iff_apply_f: "ternary_ternary_eval (map_match_tac β p (f m)) = ternary_ternary_eval (map_match_tac β p m)  matches (β,α) (f m) a p  matches (β,α) m a p"
  by(fact matches_iff_apply_f_generic)



lemma opt_MatchAny_match_expr_correct: "matches γ (opt_MatchAny_match_expr m) = matches γ m"
  proof(case_tac γ, rename_tac β α, clarify)
  fix β α
  assume "γ = (β, α)"
  have "ternary_ternary_eval (map_match_tac β p (opt_MatchAny_match_expr_once m)) =
          ternary_ternary_eval (map_match_tac β p m)" for p m
    proof(induction m rule: opt_MatchAny_match_expr_once.induct)
    qed(simp_all add: eval_ternary_simps eval_ternary_idempotence_Not)
  thus "matches (β, α) (opt_MatchAny_match_expr m) = matches (β, α) m"
    apply(simp add: fun_eq_iff)
    apply(clarify, rename_tac a p)
    apply(rule_tac f="opt_MatchAny_match_expr" in matches_iff_apply_f)
    apply(simp)
    apply(simp add: opt_MatchAny_match_expr_def)
    apply(rule repeat_stabilize_induct)
     by(simp)+
  qed



text‹An @{typ "'p unknown_match_tac"} is wf if it behaves equal for @{const Reject} and @{const Drop}
definition wf_unknown_match_tac :: "'p unknown_match_tac  bool" where
  "wf_unknown_match_tac α  (α Drop = α Reject)"


lemma wf_unknown_match_tacD_False1: "wf_unknown_match_tac α  ¬ matches (β, α) m Reject p  matches (β, α) m Drop p  False"
unfolding wf_unknown_match_tac_def by(simp add: matches_case_ternaryvalue_tuple split: ternaryvalue.split_asm)

lemma wf_unknown_match_tacD_False2: "wf_unknown_match_tac α  matches (β, α) m Reject p  ¬ matches (β, α) m Drop p  False"
unfolding wf_unknown_match_tac_def by(simp add: matches_case_ternaryvalue_tuple split: ternaryvalue.split_asm)


subsection‹Removing Unknown Primitives›

definition unknown_match_all :: "'a unknown_match_tac  action  bool" where
   "unknown_match_all α a = (p. α a p)"
definition unknown_not_match_any :: "'a unknown_match_tac  action  bool" where
   "unknown_not_match_any α a = (p. ¬ α a p)"

(*see upper_closure_matchexpr*)
fun remove_unknowns_generic :: "('a, 'packet) match_tac  action  'a match_expr  'a match_expr" where
  "remove_unknowns_generic _ _ MatchAny = MatchAny" |
  "remove_unknowns_generic _ _ (MatchNot MatchAny) = MatchNot MatchAny" |
  "remove_unknowns_generic (β, α) a (Match A) = (if
      (p. ternary_ternary_eval (map_match_tac β p (Match A)) = TernaryUnknown)
    then
      if unknown_match_all α a then MatchAny else if unknown_not_match_any α a then MatchNot MatchAny else Match A
    else (Match A))" |
  "remove_unknowns_generic (β, α) a (MatchNot (Match A)) = (if
      (p. ternary_ternary_eval (map_match_tac β p (Match A)) = TernaryUnknown)
    then
      if unknown_match_all α a then MatchAny else if unknown_not_match_any α a then MatchNot MatchAny else MatchNot (Match A)
    else MatchNot (Match A))" |
  "remove_unknowns_generic (β, α) a (MatchNot (MatchNot m)) = remove_unknowns_generic (β, α) a m" |
  "remove_unknowns_generic (β, α) a (MatchAnd m1 m2) = MatchAnd
      (remove_unknowns_generic (β, α) a m1)
      (remove_unknowns_generic (β, α) a m2)" |

  ― ‹@{text "¬ (a ∧ b) = ¬ b ∨ ¬ a"}   and   @{text "¬ Unknown = Unknown"}
  "remove_unknowns_generic (β, α) a (MatchNot (MatchAnd m1 m2)) = 
    (if (remove_unknowns_generic (β, α) a (MatchNot m1)) = MatchAny 
        (remove_unknowns_generic (β, α) a (MatchNot m2)) = MatchAny
        then MatchAny else 
        (if (remove_unknowns_generic (β, α) a (MatchNot m1)) = MatchNot MatchAny then 
          remove_unknowns_generic (β, α) a (MatchNot m2) else
         if (remove_unknowns_generic (β, α) a (MatchNot m2)) = MatchNot MatchAny then 
          remove_unknowns_generic (β, α) a (MatchNot m1) else
         MatchNot (MatchAnd (MatchNot (remove_unknowns_generic (β, α) a (MatchNot m1))) (MatchNot (remove_unknowns_generic (β, α) a (MatchNot m2)))))
       )"

lemma[code_unfold]: "remove_unknowns_generic γ a (MatchNot (MatchAnd m1 m2)) = 
    (let m1' = remove_unknowns_generic γ  a (MatchNot m1); m2' = remove_unknowns_generic γ  a (MatchNot m2) in
    (if m1' = MatchAny  m2' = MatchAny
     then MatchAny
     else 
        if m1' = MatchNot MatchAny then m2' else
        if m2' = MatchNot MatchAny then m1'
     else
        MatchNot (MatchAnd (MatchNot m1') (MatchNot m2')))
       )"
by(cases γ)(simp)


lemma remove_unknowns_generic_simp_3_4_unfolded: "remove_unknowns_generic (β, α) a (Match A) = (if
      (p. ternary_ternary_eval (map_match_tac β p (Match A)) = TernaryUnknown)
    then
      if (p. α a p) then MatchAny else if (p. ¬ α a p) then MatchNot MatchAny else Match A
    else (Match A))" 
 "remove_unknowns_generic (β, α) a (MatchNot (Match A)) = (if
      (p. ternary_ternary_eval (map_match_tac β p (Match A)) = TernaryUnknown)
    then
      if (p. α a p) then MatchAny else if (p. ¬ α a p) then MatchNot MatchAny else MatchNot (Match A)
    else MatchNot (Match A))"
  by(auto simp add: unknown_match_all_def unknown_not_match_any_def)

declare remove_unknowns_generic.simps[simp del]

lemmas remove_unknowns_generic_simps2 = remove_unknowns_generic.simps(1) remove_unknowns_generic.simps(2) 
            remove_unknowns_generic_simp_3_4_unfolded
            remove_unknowns_generic.simps(5) remove_unknowns_generic.simps(6) remove_unknowns_generic.simps(7)


lemma "matches (β, α) (remove_unknowns_generic (β, α) a (MatchNot (Match A))) a p = matches (β, α) (MatchNot (Match A)) a p"
by(simp add: remove_unknowns_generic_simps2 matches_case_ternaryvalue_tuple)



lemma remove_unknowns_generic: "matches γ (remove_unknowns_generic γ a m) a = matches γ m a"
proof -
  have "matches γ (remove_unknowns_generic γ a m) a p = matches γ m a p"
  for p
  proof(induction γ a m rule: remove_unknowns_generic.induct)
  case 3 thus ?case
      by(simp add: bunch_of_lemmata_about_matches match_raw_ternary remove_unknowns_generic_simps2)
  next
  case 4 thus ?case
     by(simp add: matches_case_ternaryvalue_tuple remove_unknowns_generic_simps2)
  next
  case 7 thus ?case
    apply(simp add: bunch_of_lemmata_about_matches matches_DeMorgan remove_unknowns_generic_simps2)
    apply(simp add: matches_case_ternaryvalue_tuple)
    by fastforce
  qed(simp_all add: bunch_of_lemmata_about_matches remove_unknowns_generic_simps2)
  thus ?thesis by(simp add: fun_eq_iff)
qed





fun has_unknowns :: " ('a, 'p) exact_match_tac  'a match_expr  bool" where
  "has_unknowns β (Match A) = (p. ternary_ternary_eval (map_match_tac β p (Match A)) = TernaryUnknown)" |
  "has_unknowns β (MatchNot m) = has_unknowns β m" |
  "has_unknowns β MatchAny = False" |
  "has_unknowns β (MatchAnd m1 m2) = (has_unknowns β m1  has_unknowns β m2)"

(* assumes simple_ruleset, thus we only care about Accept/Drop *)
definition packet_independent_α :: "'p unknown_match_tac  bool" where
  "packet_independent_α α = (a p1 p2. a = Accept  a = Drop  α a p1  α a p2)"

lemma packet_independent_unknown_match: "a = Accept  a = Drop  packet_independent_α α  ¬ unknown_not_match_any α a  unknown_match_all α a"
  by(auto simp add: packet_independent_α_def unknown_match_all_def unknown_not_match_any_def)

text‹If for some type the exact matcher returns unknown, then it returns unknown for all these types›
definition packet_independent_β_unknown :: "('a, 'packet) exact_match_tac  bool" where
  "packet_independent_β_unknown β  A. (p. β A p  TernaryUnknown)  (p. β A p  TernaryUnknown)"


lemma remove_unknowns_generic_specification: "a = Accept  a = Drop  packet_independent_α α 
  packet_independent_β_unknown β 
   ¬ has_unknowns β (remove_unknowns_generic (β, α) a m)"
  proof(induction "(β, α)" a m rule: remove_unknowns_generic.induct)
  case 3 thus ?case by(simp add: packet_independent_unknown_match packet_independent_β_unknown_def remove_unknowns_generic.simps)
  next
  case 4 thus ?case by(simp add: packet_independent_unknown_match packet_independent_β_unknown_def remove_unknowns_generic.simps)
  qed(simp_all add: remove_unknowns_generic.simps)





text‹Checking is something matches unconditionally›
context
begin
  private lemma no_primitives_no_unknown: "¬ has_primitive m   (ternary_ternary_eval (map_match_tac β p m))  TernaryUnknown"
  proof(induction m)
  case Match thus ?case by auto
  next
  case MatchAny thus ?case by simp
  next
  case MatchAnd thus ?case by(auto elim: eval_ternary_And.elims)
  next
  case MatchNot thus ?case by(auto dest: eval_ternary_Not_UnknownD)
  qed


  private lemma no_primitives_matchNot: assumes "¬ has_primitive m" shows "matches γ (MatchNot m) a p  ¬ matches γ m a p"
  proof -
    obtain β α where "(β, α) = γ" by (cases γ, simp)
    thm no_primitives_no_unknown
    from assms have "matches (β, α) (MatchNot m) a p  ¬ matches (β, α) m a p"
      apply(induction m)
         apply(simp_all add: matches_case_ternaryvalue_tuple split: ternaryvalue.split )
      apply(rename_tac m1 m2)
      by(simp split: ternaryvalue.split_asm)
    with (β, α) = γ assms show ?thesis by simp
  qed
  

  lemma matcheq_matchAny: "¬ has_primitive m  matcheq_matchAny m  matches γ m a p"
  proof(induction m)
  case Match hence False by auto
    thus ?case ..
  next
  case (MatchNot m)
    from MatchNot.prems have "¬ has_primitive m" by simp
    with no_primitives_matchNot have "matches γ (MatchNot m) a p = (¬ matches γ m a p)" by metis
    with MatchNot show ?case by(simp)
  next
  case (MatchAnd m1 m2)
    thus ?case by(simp add: bunch_of_lemmata_about_matches)
  next
  case MatchAny show ?case by(simp add: Matching_Ternary.bunch_of_lemmata_about_matches)
  qed

  lemma matcheq_matchNone: "¬ has_primitive m  matcheq_matchNone m  ¬ matches γ m a p"
    by(auto dest: matcheq_matchAny matachAny_matchNone)

  lemma matcheq_matchNone_not_matches: "matcheq_matchNone m  ¬ matches γ m a p"
    proof(induction m rule: matcheq_matchNone.induct)
    qed(auto simp add: bunch_of_lemmata_about_matches matches_DeMorgan)
    
end



text‹Lemmas about @{const MatchNot} in ternary logic.›

lemma matches_MatchNot_no_unknowns:
   assumes "¬ has_unknowns β m"
   shows "matches (β,α) (MatchNot m) a p  ¬ matches (β,α) m a p"
proof -
  { fix m have "¬ has_unknowns β m 
       ternary_to_bool (ternary_ternary_eval (map_match_tac β p m))  None"
    apply(induction m)
       apply(simp_all)
      using ternary_to_bool.elims apply blast
     using ternary_to_bool_Some apply fastforce
    using ternary_lift(6) ternary_to_bool_Some by auto
  } note no_unknowns_ternary_to_bool_Some=this
    from assms show ?thesis
      by(auto split: option.split_asm
              simp: matches_case_tuple no_unknowns_ternary_to_bool_Some ternary_to_bool_Some  ternary_eval_def ternary_to_bool_bool_to_ternary
              elim: ternary_to_bool.elims)
qed

lemma MatchNot_ternary_ternary_eval: "(ternary_ternary_eval (map_match_tac β p m')) = (ternary_ternary_eval (map_match_tac β p m)) 
    matches (β,α) (MatchNot m') a p = matches (β,α) (MatchNot m) a p"
by(simp add: matches_tuple)



text‹For our @{typ "'p unknown_match_tac"}s in_doubt_allow› and in_doubt_deny›,
      when doing an induction over some function that modifies @{term "m::'a match_expr"},
      we get the @{const MatchNot} case for free (if we can set arbitrary @{term "p::'p"}).
      This does not hold for arbitrary @{typ "'p unknown_match_tac"}s.›
lemma matches_induction_case_MatchNot:
      assumes "α Drop  α Accept" and "packet_independent_α α"
      and     " a. matches (β,α) m' a p = matches (β,α) m a p"
      shows   "matches (β,α) (MatchNot m') a p = matches (β,α) (MatchNot m) a p"
proof -
  from assms(1) assms(2) have xxxx_xxX: "b. a. α a p = (¬ b)  False"
    apply(simp add: packet_independent_α_def)
    apply(case_tac "α Accept p")
     apply(simp_all)
     apply(case_tac [!] "α Drop p")
       apply(simp_all add: fun_eq_iff)
     apply blast+
    done

  have xx2: "t. ternary_eval (TernaryNot t) = None  ternary_eval t = None"
  by (simp add: eval_ternary_Not_UnknownD ternary_eval_def ternary_to_bool_None)
  
  have xx3: "t b. ternary_eval (TernaryNot t) = Some b   ternary_eval t = Some (¬ b)"
  by (metis eval_ternary_Not.simps(1) eval_ternary_Not.simps(2) ternary_eval_def ternary_ternary_eval.simps(3) ternary_ternary_eval_idempotence_Not ternary_to_bool_Some)

  from assms show ?thesis
    apply(simp add: matches_case_tuple)
    apply(case_tac "ternary_eval (TernaryNot (map_match_tac β p m'))")
     apply(case_tac [!] "ternary_eval (TernaryNot (map_match_tac β p m))")
       apply(simp_all)
      apply(drule xx2)
      apply(drule xx3)
      apply(simp)
      using xxxx_xxX apply metis
     apply(drule xx2)
     apply(drule xx3)
     apply(simp)
     using xxxx_xxX apply metis
    apply(drule xx3)+
    apply(simp)
    done
qed



end

Theory Semantics_Ternary

theory Semantics_Ternary
imports Matching_Ternary "../Common/List_Misc"
begin

section‹Embedded Ternary-Matching Big Step Semantics›

subsection‹Ternary Semantics (Big Step)›

inductive approximating_bigstep :: "('a, 'p) match_tac  'p  'a rule list  state  state  bool"
  ("_,_ _, _ α _"  [60,60,20,98,98] 89)
  for γ and p where
skip:  "γ,p [], t α t" |
accept:  "matches γ m Accept p  γ,p [Rule m Accept], Undecided α Decision FinalAllow" |
drop:  "matches γ m Drop p  γ,p [Rule m Drop], Undecided α Decision FinalDeny" |
reject:  "matches γ m Reject p   γ,p [Rule m Reject], Undecided α Decision FinalDeny" |
log:   "matches γ m Log p  γ,p [Rule m Log], Undecided α Undecided" |
empty:   "matches γ m Empty p  γ,p [Rule m Empty], Undecided α Undecided" |
nomatch:  "¬ matches γ m a p  γ,p [Rule m a], Undecided α Undecided" | 
decision:  "γ,p rs, Decision X α Decision X" |
seq:  "γ,p rs1, Undecided α t; γ,p rs2, t α t'  γ,p rs1@rs2, Undecided α t'" 



thm approximating_bigstep.induct[of γ p rs s t P]
(*tuned induction rule*)
lemma approximating_bigstep_induct[case_names Skip Allow Deny Log Nomatch Decision Seq, induct pred: approximating_bigstep] : "γ,p rs,s α t 
(t. P [] t t) 
(m a. matches γ m a p  a = Accept  P [Rule m a] Undecided (Decision FinalAllow)) 
(m a. matches γ m a p  a = Drop  a = Reject  P [Rule m a] Undecided (Decision FinalDeny)) 
(m a. matches γ m a p  a = Log  a = Empty  P [Rule m a] Undecided Undecided) 
(m a. ¬ matches γ m a p  P [Rule m a] Undecided Undecided) 
(rs X. P rs (Decision X) (Decision X)) 
(rs rs1 rs2 t t'. rs = rs1 @ rs2  γ,p rs1,Undecided α t  P rs1 Undecided t  γ,p rs2,t α t'  P rs2 t t'  P rs Undecided t')
    P rs s t"
by (induction rule: approximating_bigstep.induct) (simp_all)


lemma skipD: "γ,p [], s α t  s = t"
by (induction "[]::'a rule list" s t rule: approximating_bigstep_induct) (simp_all)

lemma decisionD: "γ,p rs, Decision X α t  t = Decision X"
by (induction rs "Decision X" t rule: approximating_bigstep_induct) (simp_all)

lemma acceptD: "γ,p [Rule m Accept], Undecided α t  matches γ m Accept p  t = Decision FinalAllow"
proof (induction "[Rule m Accept]" Undecided t rule: approximating_bigstep_induct)
  case Seq thus ?case by (metis list_app_singletonE skipD)
qed(simp_all)

lemma dropD: "γ,p [Rule m Drop], Undecided α t  matches γ m Drop p  t = Decision FinalDeny"
apply (induction "[Rule m Drop]" Undecided t rule: approximating_bigstep_induct)
by(auto dest: skipD elim!: rules_singleton_rev_E)

lemma rejectD: "γ,p [Rule m Reject], Undecided α t  matches γ m Reject p  t = Decision FinalDeny"
apply (induction "[Rule m Reject]" Undecided t rule: approximating_bigstep_induct)
by(auto dest: skipD elim!: rules_singleton_rev_E)

lemma logD: "γ,p [Rule m Log], Undecided α t  t = Undecided"
apply (induction "[Rule m Log]" Undecided t rule: approximating_bigstep_induct)
by(auto dest: skipD elim!: rules_singleton_rev_E)

lemma emptyD: "γ,p [Rule m Empty], Undecided α t  t = Undecided"
apply (induction "[Rule m Empty]" Undecided t rule: approximating_bigstep_induct)
by(auto dest: skipD elim!: rules_singleton_rev_E)

lemma nomatchD: "γ,p [Rule m a], Undecided α t  ¬ matches γ m a p  t = Undecided"
apply (induction "[Rule m a]" Undecided t rule: approximating_bigstep_induct)
by(auto dest: skipD elim!: rules_singleton_rev_E)

lemmas approximating_bigstepD = skipD acceptD dropD rejectD logD emptyD nomatchD decisionD

lemma approximating_bigstep_to_undecided: "γ,p rs, s α Undecided  s = Undecided"
  by (metis decisionD state.exhaust)

lemma approximating_bigstep_to_decision1: "γ,p rs, Decision Y α Decision X  Y = X"
  by (metis decisionD state.inject)

lemma nomatch_fst: "¬ matches γ m a p   γ,p rs, s α t  γ,p Rule m a # rs, s α t"
  apply(cases s)
   apply(clarify)
   apply(drule nomatch)
   apply(drule(1) seq)
   apply (simp; fail)
  apply(clarify)
  apply(drule decisionD)
  apply(clarify)
 apply(simp add: decision)
done

lemma seq':
  assumes "rs = rs1 @ rs2" "γ,p rs1,s α t" "γ,p rs2,t α t'"
  shows "γ,p rs,s α t'"
using assms by (cases s) (auto intro: seq decision dest: decisionD)

lemma seq_split:
  assumes "γ,p rs, s α t" "rs = rs1@rs2"
  obtains t' where "γ,p rs1,s α t'" "γ,p rs2,t' α t"
  using assms
  proof (induction rs s t arbitrary: rs1 rs2 thesis rule: approximating_bigstep_induct)
    case Allow thus ?case by (auto dest: skipD elim!: rules_singleton_rev_E intro: approximating_bigstep.intros)
  next
    case Deny thus ?case by (auto dest: skipD elim!: rules_singleton_rev_E intro: approximating_bigstep.intros)
  next
    case Log thus ?case by (auto dest: skipD elim!: rules_singleton_rev_E intro: approximating_bigstep.intros)
  next
    case Nomatch thus ?case by (auto dest: skipD elim!: rules_singleton_rev_E intro: approximating_bigstep.intros)
  next
    case (Seq rs rsa rsb t t')
    hence rs: "rsa @ rsb = rs1 @ rs2" by simp
    note List.append_eq_append_conv_if[simp]
    from rs show ?case
      proof (cases rule: list_app_eq_cases)
        case longer
        with Seq have t1: "γ,p take (length rsa) rs1, Undecided α t"
          by simp
        from Seq longer obtain t2
          where t2a: "γ,p drop (length rsa) rs1,t α t2"
            and rs2_t2: "γ,p rs2,t2 α t'"
          by blast
        with t1 rs2_t2 have "γ,p take (length rsa) rs1 @ drop (length rsa) rs1,Undecided α t2"
          by (blast intro: approximating_bigstep.seq)
        with Seq rs2_t2 show ?thesis
          by simp
      next
        case shorter
        with rs have rsa': "rsa = rs1 @ take (length rsa - length rs1) rs2"
          by (metis append_eq_conv_conj length_drop)
        from shorter rs have rsb': "rsb = drop (length rsa - length rs1) rs2"
          by (metis append_eq_conv_conj length_drop)
        from Seq rsa' obtain t1
          where t1a: "γ,p rs1,Undecided α t1"
            and t1b: "γ,p take (length rsa - length rs1) rs2,t1 α t"
          by blast
        from rsb' Seq.hyps have t2: "γ,p drop (length rsa - length rs1) rs2,t α t'"
          by blast
        with seq' t1b have "γ,p rs2,t1 α t'" by (metis append_take_drop_id)
        with Seq t1a show ?thesis
          by fast
      qed
  qed (auto intro: approximating_bigstep.intros)


lemma seqE_fst:
  assumes "γ,p r#rs, s α t"
  obtains t' where "γ,p [r],s α t'" "γ,p rs,t' α t"
  using assms seq_split by (metis append_Cons append_Nil)

lemma seq_fst: assumes "γ,p [r], s α t" and "γ,p rs, t α t'" shows "γ,p r # rs, s α t'"
proof(cases s)
  case Undecided with assms seq show "γ,p r # rs, s α t'" by fastforce
  next
  case Decision with assms show "γ,p r # rs, s α t'"
  by(auto simp: decision dest!: decisionD)
qed


subsection‹wf ruleset›
  text‹
  A @{typ "'a rule list"} here is well-formed (for a packet) if
     either the rules do not match
     or the action is not @{const Call}, not @{const Return}, not @{const Unknown}
  definition wf_ruleset :: "('a, 'p) match_tac  'p  'a rule list  bool" where
    "wf_ruleset γ p rs  r  set rs. 
      (¬ matches γ (get_match r) (get_action r) p)  
      (¬(chain. get_action r = Call chain)  get_action r  Return  ¬(chain. get_action r = Goto chain)  get_action r  Unknown)"

  lemma wf_ruleset_append: "wf_ruleset γ p (rs1@rs2)  wf_ruleset γ p rs1  wf_ruleset γ p rs2"
    by(auto simp add: wf_ruleset_def)
  lemma wf_rulesetD: assumes "wf_ruleset γ p (r # rs)" shows "wf_ruleset γ p [r]" and "wf_ruleset γ p rs"
    using assms by(auto simp add: wf_ruleset_def)
  lemma wf_ruleset_fst: "wf_ruleset γ p (Rule m a # rs)  wf_ruleset γ p [Rule m a]  wf_ruleset γ p rs"
    by(auto simp add: wf_ruleset_def)
  lemma wf_ruleset_stripfst: "wf_ruleset γ p (r # rs)  wf_ruleset γ p (rs)"
    by(simp add: wf_ruleset_def)
  lemma wf_ruleset_rest: "wf_ruleset γ p (Rule m a # rs)  wf_ruleset γ p [Rule m a]"
    by(simp add: wf_ruleset_def)

subsection‹Ternary Semantics (Function)›

fun approximating_bigstep_fun :: "('a, 'p) match_tac  'p  'a rule list  state  state" where
  "approximating_bigstep_fun γ p [] s = s" |
  "approximating_bigstep_fun γ p rs (Decision X) = (Decision X)" |
  "approximating_bigstep_fun γ p ((Rule m a)#rs) Undecided = (if 
      ¬ matches γ m a p
    then
      approximating_bigstep_fun γ p rs Undecided
    else
      case a of Accept  Decision FinalAllow
              | Drop  Decision FinalDeny
              | Reject  Decision FinalDeny
              | Log  approximating_bigstep_fun γ p rs Undecided
              | Empty  approximating_bigstep_fun γ p rs Undecided
              ― ‹unhandled cases›
              )"



(*tuned induction rule*)
lemma approximating_bigstep_fun_induct[case_names Empty Decision Nomatch Match] : "
(γ p s. P γ p [] s) 
(γ p r rs X. P γ p (r # rs) (Decision X)) 
(γ p m a rs.
    ¬ matches γ m a p  P γ p rs Undecided  P γ p (Rule m a # rs) Undecided) 
(γ p m a rs.
    matches γ m a p  (a = Log  P γ p rs Undecided)  (a = Empty  P γ p rs Undecided)  P γ p (Rule m a # rs) Undecided) 
P γ p rs s"
apply (rule approximating_bigstep_fun.induct[of P γ p rs s])
  apply (simp_all)
by metis

lemma Decision_approximating_bigstep_fun: "approximating_bigstep_fun γ p rs (Decision X) = Decision X"
  by(induction rs) (simp_all)

  
lemma approximating_bigstep_fun_induct_wf[case_names Empty Decision Nomatch MatchAccept MatchDrop MatchReject MatchLog MatchEmpty, consumes 1]:
  "wf_ruleset γ p rs 
(γ p s. P γ p [] s) 
(γ p r rs X. P γ p (r # rs) (Decision X)) 
(γ p m a rs.
    ¬ matches γ m a p  P γ p rs Undecided  P γ p (Rule m a # rs) Undecided) 
(γ p m a rs.
    matches γ m a p  a = Accept   P γ p (Rule m a # rs) Undecided) 
(γ p m a rs.
    matches γ m a p  a = Drop  P γ p (Rule m a # rs) Undecided) 
(γ p m a rs.
    matches γ m a p  a = Reject  P γ p (Rule m a # rs) Undecided) 
(γ p m a rs.
    matches γ m a p  a = Log  P γ p rs Undecided   P γ p (Rule m a # rs) Undecided) 
(γ p m a rs.
    matches γ m a p  a = Empty  P γ p rs Undecided  P γ p (Rule m a # rs) Undecided) 
P γ p rs s"
  proof(induction γ p rs s rule: approximating_bigstep_fun_induct)
  case Empty thus ?case by blast
  next
  case Decision thus ?case by blast
  next
  case Nomatch thus ?case by(simp add: wf_ruleset_def)
  next
  case (Match γ p m a) thus ?case
    apply -
    apply(frule wf_rulesetD(1), drule wf_rulesetD(2))
    apply(simp)
    apply(cases a)
           apply(simp_all)
      apply(auto simp add: wf_ruleset_def)
    done
  qed

lemma just_show_all_approximating_bigstep_fun_equalities_with_start_Undecided[case_names Undecided]: 
      assumes "s = Undecided  approximating_bigstep_fun γ p rs1 s = approximating_bigstep_fun γ p rs2 s"
      shows "approximating_bigstep_fun γ p rs1 s = approximating_bigstep_fun γ p rs2 s"
  proof(cases s)
  case Undecided thus ?thesis using assms by simp
  next
  case Decision thus ?thesis by (simp add: Decision_approximating_bigstep_fun)
  qed

subsubsection‹Append, Prepend, Postpend, Composition›
  lemma approximating_bigstep_fun_seq_wf: " wf_ruleset γ p rs1 
      approximating_bigstep_fun γ p (rs1 @ rs2) s = approximating_bigstep_fun γ p rs2 (approximating_bigstep_fun γ p rs1 s)"
   proof(induction γ p rs1 s rule: approximating_bigstep_fun_induct)
   qed(simp_all add: wf_ruleset_def Decision_approximating_bigstep_fun split: action.split)

  text‹The state transitions from @{const Undecided} to @{const Undecided} if all intermediate states are @{const Undecided}
 lemma approximating_bigstep_fun_seq_Undecided_wf: " wf_ruleset γ p (rs1@rs2)  
      approximating_bigstep_fun γ p (rs1@rs2) Undecided = Undecided  
  approximating_bigstep_fun γ p rs1 Undecided = Undecided  approximating_bigstep_fun γ p rs2 Undecided = Undecided"
    proof(induction γ p rs1 Undecided rule: approximating_bigstep_fun_induct)
    qed(simp_all add: wf_ruleset_def split: action.split)


  lemma approximating_bigstep_fun_seq_Undecided_t_wf: " wf_ruleset γ p (rs1@rs2)  
      approximating_bigstep_fun γ p (rs1@rs2) Undecided = t  
  approximating_bigstep_fun γ p rs1 Undecided = Undecided  approximating_bigstep_fun γ p rs2 Undecided = t 
  approximating_bigstep_fun γ p rs1 Undecided = t  t  Undecided"
  proof(induction γ p rs1 Undecided rule: approximating_bigstep_fun_induct)
  case Empty thus ?case by(cases t) simp_all
  next
  case Nomatch thus ?case by(simp add: wf_ruleset_def)
  next
  case Match thus ?case by(auto simp add: wf_ruleset_def split: action.split)
  qed
 

  lemma approximating_bigstep_fun_wf_postpend: "wf_ruleset γ p rsA  wf_ruleset γ p rsB  
      approximating_bigstep_fun γ p rsA s = approximating_bigstep_fun γ p rsB s  
      approximating_bigstep_fun γ p (rsA@rsC) s = approximating_bigstep_fun γ p (rsB@rsC) s"
  apply(induction γ p rsA s rule: approximating_bigstep_fun_induct_wf)
         apply(simp_all add: approximating_bigstep_fun_seq_wf)
     apply (metis Decision_approximating_bigstep_fun)+
  done


lemma approximating_bigstep_fun_singleton_prepend:
    assumes "approximating_bigstep_fun γ p rsB s = approximating_bigstep_fun γ p rsC s"
    shows "approximating_bigstep_fun γ p (r#rsB) s = approximating_bigstep_fun γ p (r#rsC) s"
  proof(cases s)
  case Decision thus ?thesis by(simp add: Decision_approximating_bigstep_fun)
  next
  case Undecided
  with assms show ?thesis by(cases r)(simp split: action.split)
  qed

subsection‹Equality with @{term "γ,p rs, s α t"} semantics›
  lemma approximating_bigstep_wf: "γ,p rs, Undecided α Undecided  wf_ruleset γ p rs"
  unfolding wf_ruleset_def
  proof(induction rs Undecided Undecided rule: approximating_bigstep_induct)
    case Skip thus ?case by simp
    next
    case Log thus ?case by auto
    next
    case Nomatch thus ?case by simp
    next
    case (Seq rs rs1 rs2 t)
      from Seq approximating_bigstep_to_undecided have "t = Undecided" by fast
      from this Seq show ?case by auto
  qed
  

  text‹only valid actions appear in this ruleset›
  definition good_ruleset :: "'a rule list  bool" where
    "good_ruleset rs  r  set rs. (¬(chain. get_action r = Call chain)  get_action r  Return  ¬(chain. get_action r = Goto chain)  get_action r  Unknown)"

  lemma[code_unfold]: "good_ruleset rs = (rset rs. (case get_action r of Call chain  False | Return  False | Goto chain  False | Unknown  False | _  True))"
      unfolding good_ruleset_def
      apply(rule Set.ball_cong)
       apply(simp_all)
      apply(rename_tac r)
      by(case_tac "get_action r")(simp_all)
      

  lemma good_ruleset_alt: "good_ruleset rs = (rset rs. get_action r = Accept  get_action r = Drop 
                                                get_action r = Reject  get_action r = Log   get_action r = Empty)"
      unfolding good_ruleset_def
      apply(rule Set.ball_cong)
       apply(simp_all)
      apply(rename_tac r)
      by(case_tac "get_action r")(simp_all)


  lemma good_ruleset_append: "good_ruleset (rs1 @ rs2)  good_ruleset rs1  good_ruleset rs2"
    by(simp add: good_ruleset_alt, blast)

  lemma good_ruleset_fst: "good_ruleset (r#rs)  good_ruleset [r]"
    by(simp add: good_ruleset_def)
  lemma good_ruleset_tail: "good_ruleset (r#rs)  good_ruleset rs"
    by(simp add: good_ruleset_def)

  text@{term good_ruleset} is stricter than @{term wf_ruleset}. It can be easily checked with running code!
›
  lemma good_imp_wf_ruleset: "good_ruleset rs  wf_ruleset γ p rs" by (metis good_ruleset_def wf_ruleset_def)

  lemma simple_imp_good_ruleset: "simple_ruleset rs  good_ruleset rs"
    by(simp add: simple_ruleset_def good_ruleset_def, fastforce)


lemma approximating_bigstep_fun_seq_semantics: " γ,p rs1, s α t   
    approximating_bigstep_fun γ p (rs1 @ rs2) s = approximating_bigstep_fun γ p rs2 t"
  proof(induction rs1 s t arbitrary: rs2 rule: approximating_bigstep.induct)
  qed(simp_all add: Decision_approximating_bigstep_fun)

lemma approximating_semantics_imp_fun: "γ,p rs, s α t  approximating_bigstep_fun γ p rs s = t"
  proof(induction rs s t rule: approximating_bigstep_induct)
  qed(auto simp add: approximating_bigstep_fun_seq_semantics Decision_approximating_bigstep_fun)

lemma approximating_fun_imp_semantics: assumes "wf_ruleset γ p rs"
      shows "approximating_bigstep_fun γ p rs s = t  γ,p rs, s α t"
  using assms proof(induction γ p rs s rule: approximating_bigstep_fun_induct_wf)
    case (Empty γ p s)
      thus "γ,p [], s α t"  using skip by(simp)
    next
    case (Decision γ p r rs X)
      hence "t = Decision X" by simp
      thus "γ,p r # rs, Decision X α t" using decision by fast
    next
    case (Nomatch γ p m a rs)
      thus "γ,p Rule m a # rs, Undecided α t"
        apply(rule_tac t=Undecided in seq_fst)
         apply(simp add: nomatch)
        apply(simp add: Nomatch.IH)
        done
    next
    case (MatchAccept γ p m a rs)
      hence "t = Decision FinalAllow" by simp
      thus ?case by (metis MatchAccept.hyps accept decision seq_fst)
    next
    case (MatchDrop γ p m a rs)
      hence "t = Decision FinalDeny" by simp
      thus ?case by (metis MatchDrop.hyps drop decision seq_fst)
    next
    case (MatchReject γ p m a rs)
      hence "t = Decision FinalDeny" by simp
      thus ?case by (metis MatchReject.hyps reject decision seq_fst)
    next
    case (MatchLog γ p m a rs)
      thus ?case
        apply(simp)
        apply(rule_tac t=Undecided in seq_fst)
         apply(simp add: log)
        apply(simp add: MatchLog.IH)
        done
    next
    case (MatchEmpty γ p m a rs)
      thus ?case
        apply(simp)
        apply(rule_tac t=Undecided in seq_fst)
         apply(simp add: empty)
        apply(simp add: MatchEmpty.IH)
        done
    qed


text‹Henceforth, we will use the @{term approximating_bigstep_fun} semantics, because they are easier.
We show that they are equal.
›
theorem approximating_semantics_iff_fun: "wf_ruleset γ p rs 
    γ,p rs, s α t  approximating_bigstep_fun γ p rs s = t"
by (metis approximating_fun_imp_semantics approximating_semantics_imp_fun)

corollary approximating_semantics_iff_fun_good_ruleset: "good_ruleset rs 
    γ,p rs, s α t  approximating_bigstep_fun γ p rs s = t"
  by (metis approximating_semantics_iff_fun good_imp_wf_ruleset)

lemma approximating_bigstep_deterministic: " γ,p rs, s α t; γ,p rs, s α t'   t = t'"
  proof(induction arbitrary: t' rule: approximating_bigstep_induct)
  case Seq thus ?case
    by (metis (hide_lams, mono_tags) append_Nil2 approximating_bigstep_fun.simps(1) approximating_bigstep_fun_seq_semantics)
  qed(auto dest: approximating_bigstepD)



lemma rm_LogEmpty_fun_semantics: 
  "approximating_bigstep_fun γ p (rm_LogEmpty rs) s = approximating_bigstep_fun γ p rs s"
  proof(induction γ p rs s rule: approximating_bigstep_fun_induct)
    case Empty thus ?case by(simp)
    next
    case Decision thus ?case by(simp add: Decision_approximating_bigstep_fun)
    next
    case (Nomatch γ p m a rs) thus ?case by(cases a,simp_all)
    next
    case (Match γ p m a rs) thus ?case by(cases a,simp_all)
  qed


(*we probably don't need the following*)
lemma "γ,p rm_LogEmpty rs, s α t  γ,p rs, s α t"
apply(rule iffI)
 apply(induction rs arbitrary: s t)
  apply(simp_all)
 apply(rename_tac r rs s t)
 apply(case_tac r)
 apply(simp)
 apply(rename_tac m a)
 apply(case_tac a)
         apply(simp_all)
         apply(auto intro: approximating_bigstep.intros )
         apply(erule seqE_fst, simp add: seq_fst)
        apply(erule seqE_fst, simp add: seq_fst)
       apply (metis decision log nomatch_fst seq_fst state.exhaust)
      apply(erule seqE_fst, simp add: seq_fst)
     apply(erule seqE_fst, simp add: seq_fst)
    apply(erule seqE_fst, simp add: seq_fst)
   apply(erule seqE_fst, simp add: seq_fst)
  apply (metis decision empty nomatch_fst seq_fst state.exhaust)
 apply(erule seqE_fst, simp add: seq_fst)
apply(induction rs s t rule: approximating_bigstep_induct)
      apply(auto intro: approximating_bigstep.intros)
 apply(rename_tac m a)
 apply(case_tac a)
         apply(auto intro: approximating_bigstep.intros)
apply(rename_tac rs1 rs2 t t')
apply(drule_tac rs1="rm_LogEmpty rs1" and rs2="rm_LogEmpty rs2" in seq)
 apply(simp_all)
using rm_LogEmpty_seq apply metis
done


lemma rm_LogEmpty_simple_but_Reject: 
  "good_ruleset rs  r  set (rm_LogEmpty rs). get_action r = Accept  get_action r = Reject  get_action r = Drop"
  proof(induction rs)
  case Nil thus ?case by(simp add: good_ruleset_def)
  next
  case (Cons r rs) thus ?case
    apply(clarify)
    apply(cases r, rename_tac m a, simp)
    by(case_tac a) (auto simp add: good_ruleset_def)
  qed



lemma rw_Reject_fun_semantics: 
  "wf_unknown_match_tac α  
  (approximating_bigstep_fun (β, α) p (rw_Reject rs) s = approximating_bigstep_fun (β, α) p rs s)"
  proof(induction rs)
  case Nil thus ?case by simp
  next
  case (Cons r rs)
    thus ?case
      apply(case_tac r, rename_tac m a, simp)
      apply(case_tac a)
              apply(case_tac [!] s)
                      apply(auto dest: wf_unknown_match_tacD_False1 wf_unknown_match_tacD_False2)
      done
    qed

lemma rmLogEmpty_rwReject_good_to_simple: "good_ruleset rs  simple_ruleset (rw_Reject (rm_LogEmpty rs))"
  apply(drule rm_LogEmpty_simple_but_Reject)
  apply(simp add: simple_ruleset_def)
  apply(induction rs)
   apply(simp_all)
  apply(rename_tac r rs)
  apply(case_tac r)
  apply(rename_tac m a)
  apply(case_tac a)
          apply(simp_all)
  done

subsection‹Matching›
lemma optimize_matches_option_generic:
  assumes " r  set rs. P (get_match r) (get_action r)"
      and "(m m' a. P m a  f m = Some m'  matches γ m' a p = matches γ m a p)"
      and "(m a. P m a  f m = None  ¬ matches γ m a p)"
  shows "approximating_bigstep_fun γ p (optimize_matches_option f rs) s = approximating_bigstep_fun γ p rs s"
    using assms proof(induction γ p rs s rule: approximating_bigstep_fun_induct)
      case Decision thus ?case by (simp add: Decision_approximating_bigstep_fun)
    next
      case (Nomatch γ p m a rs) thus ?case
        apply(simp)
        apply(cases "f m")
         apply(simp; fail)
        apply(simp del: approximating_bigstep_fun.simps)
        apply(rename_tac m')
        apply(subgoal_tac "¬ matches γ m' a p")
         apply(simp; fail)
        using assms by blast
    next
      case (Match γ p m a rs) thus ?case
        apply(cases "f m")
         apply(simp; fail)
        apply(simp del: approximating_bigstep_fun.simps)
        apply(rename_tac m')
        apply(subgoal_tac "matches γ m' a p")
         apply(simp split: action.split; fail)
        using assms by blast
    qed(simp)


lemma optimize_matches_generic: " r  set rs. P (get_match r) (get_action r)  
      (m a. P m a  matches γ (f m) a p = matches γ m a p) 
      approximating_bigstep_fun γ p (optimize_matches f rs) s = approximating_bigstep_fun γ p rs s"
  unfolding optimize_matches_def
  apply(rule optimize_matches_option_generic)
    apply(simp; fail)
   apply(simp split: if_split_asm)
   apply blast
  apply(simp split: if_split_asm)
  using matcheq_matchNone_not_matches by fast


lemma optimize_matches_matches_fst: "matches γ (f m) a p  optimize_matches f (Rule m a # rs) = (Rule (f m) a)# optimize_matches f rs"
  apply(simp add: optimize_matches_def)
  by (meson matcheq_matchNone_not_matches)


lemma optimize_matches: "m a. matches γ (f m) a p = matches γ m a p  approximating_bigstep_fun γ p (optimize_matches f rs) s = approximating_bigstep_fun γ p rs s"
  using optimize_matches_generic[where P="λ_ _. True"] by metis


lemma optimize_matches_opt_MatchAny_match_expr: "approximating_bigstep_fun γ p (optimize_matches opt_MatchAny_match_expr rs) s = approximating_bigstep_fun γ p rs s"
using optimize_matches opt_MatchAny_match_expr_correct by metis


lemma optimize_matches_a: "a m. matches γ m a = matches γ (f a m) a  approximating_bigstep_fun γ p (optimize_matches_a f rs) s = approximating_bigstep_fun γ p rs s"
  proof(induction γ p rs s rule: approximating_bigstep_fun_induct)
    case (Match γ p m a rs) thus ?case by(case_tac a)(simp_all add: optimize_matches_a_def)
  qed(simp_all add: optimize_matches_a_def)


lemma optimize_matches_a_simplers:
  assumes "simple_ruleset rs" and "a m. a = Accept  a = Drop  matches γ (f a m) a = matches γ m a"
  shows "approximating_bigstep_fun γ p (optimize_matches_a f rs) s = approximating_bigstep_fun γ p rs s"
proof -
  from assms(1) have "wf_ruleset γ p rs" by(simp add: simple_imp_good_ruleset good_imp_wf_ruleset)
  from ‹wf_ruleset γ p rs assms show "approximating_bigstep_fun γ p (optimize_matches_a f rs) s = approximating_bigstep_fun γ p rs s"
    proof(induction γ p rs s rule: approximating_bigstep_fun_induct_wf)
    case Nomatch thus ?case
     apply(simp add: optimize_matches_a_def simple_ruleset_def)
     apply(safe)
      apply(simp_all)
    done
    next
    case MatchReject thus ?case by(simp add: optimize_matches_a_def simple_ruleset_def)
    qed(simp_all add: optimize_matches_a_def simple_ruleset_tail)
qed



lemma not_matches_removeAll: "¬ matches γ m a p 
  approximating_bigstep_fun γ p (removeAll (Rule m a) rs) Undecided = approximating_bigstep_fun γ p rs Undecided"
  apply(induction γ p rs Undecided rule: approximating_bigstep_fun.induct)
   apply(simp)
  apply(simp split: action.split)
  apply blast
  done


end

Theory Datatype_Selectors

theory Datatype_Selectors
imports Main
begin

text‹
  Running Example: datatype_new iptrule_match = is_Src: Src (src_range: ipt_iprange)›

  A discriminator disc› tells whether a value is of a certain constructor.
    Example: is_Src›

  A selector sel› select the inner value.
    Example: src_range›

  A constructor C› constructs a value
    Example: Src›


  The are well-formed if the belong together.
›
fun wf_disc_sel :: "(('a  bool) × ('a  'b))  ('b  'a)  bool" where
  "wf_disc_sel (disc, sel) C  (a. disc a  C (sel a) = a)  (a. ⌦‹disc (C a) ⟶› sel (C a) = a)"

(* should the following be added to the definition?
 the discriminator is true for all C independent of the a
 for example: is_Src_IP is true for all Src_IPs, independent of the numberic value of the ip.
lemma "wf_disc_sel (disc, sel) C ⟹ (∃a. disc (C a)) ⟶ (∀a. disc (C a))"
*)

declare wf_disc_sel.simps[simp del]

end

Theory IpAddresses

theory IpAddresses
imports IP_Addresses.IP_Address_toString
  IP_Addresses.CIDR_Split
  "../Common/WordInterval_Lists"
begin




― ‹Misc›
(*we dont't have an empty ip space, but a space which only contains the 0 address. We will use the option type to denote the empty space in some functions.*)
lemma "ipset_from_cidr (ipv4addr_of_dotdecimal (0, 0, 0, 0)) 33 = {0}"
  by(simp add: ipv4addr_of_dotdecimal.simps ipv4addr_of_nat_def ipset_from_cidr_large_pfxlen)
  

  (*helper we use for spoofing protection specification*)
  definition all_but_those_ips :: "('i::len word × nat) list  ('i word × nat) list" where
    "all_but_those_ips cidrips = cidr_split (wordinterval_invert (l2wi (map ipcidr_to_interval cidrips)))"
  
  lemma all_but_those_ips:
    "ipcidr_union_set (set (all_but_those_ips cidrips)) =
      UNIV - ( (ip,n)  set cidrips. ipset_from_cidr ip n)"
    apply(simp add: )
    unfolding ipcidr_union_set_uncurry all_but_those_ips_def
    apply(simp add: cidr_split_prefix)
    apply(simp add: l2wi)
    apply(simp add: ipcidr_to_interval_def)
    using ipset_from_cidr_ipcidr_to_interval by blast
  

section‹IPv4 Addresses›



subsection‹IPv4 Addresses in IPTables Notation (how we parse it)›
  context
    notes [[typedef_overloaded]]
  begin
    datatype 'i ipt_iprange =
                          ― ‹Singleton IP Address›
                          IpAddr "'i::len word"
  
                          ― ‹CIDR notation: addr/xx›
                          | IpAddrNetmask "'i word" nat
  
                          ― ‹-m iprange --src-range a.b.c.d-e.f.g.h›
                          | IpAddrRange  "'i word" "'i word"
                              (*the range is inclusive*)
  end  
  
  fun ipt_iprange_to_set :: "'i::len ipt_iprange  'i word set" where
    "ipt_iprange_to_set (IpAddrNetmask base m) = ipset_from_cidr base m" |
    "ipt_iprange_to_set (IpAddr ip) = { ip }" |
    "ipt_iprange_to_set (IpAddrRange ip1 ip2) = { ip1 .. ip2 }"
  
  text@{term ipt_iprange_to_set} can only represent an empty set if it is an empty range.›
  lemma ipt_iprange_to_set_nonempty: "ipt_iprange_to_set ip = {}  
    (ip1 ip2. ip = IpAddrRange ip1 ip2  ip1 > ip2)"
    apply(cases ip)
      apply(simp; fail)
     apply(simp add: ipset_from_cidr_alt bitmagic_zeroLast_leq_or1Last; fail)
    apply(simp add:linorder_not_le; fail)
    done
  
  text‹maybe this is necessary as code equation?›
  lemma element_ipt_iprange_to_set[code_unfold]: "(addr::'i::len word)  ipt_iprange_to_set X = (
    case X of (IpAddrNetmask pre len) 
                  (pre AND ((mask len) << (len_of (TYPE('i)) - len)))  addr 
                  addr  pre OR (mask (len_of (TYPE('i)) - len))
    | IpAddr ip  (addr = ip)
    | IpAddrRange ip1 ip2  ip1  addr  ip2  addr)"
  apply(cases X)
    apply(simp; fail)
   apply(simp add: ipset_from_cidr_alt; fail)
  apply(simp; fail)
  done

  
  lemma ipt_iprange_to_set_uncurry_IpAddrNetmask:
    "ipt_iprange_to_set (uncurry IpAddrNetmask a) = uncurry ipset_from_cidr a"
    by(simp split: uncurry_splits)
  

  text‹IP address ranges to (start, end)› notation›
  fun ipt_iprange_to_interval :: "'i::len ipt_iprange  ('i word × 'i word)" where
    "ipt_iprange_to_interval (IpAddr addr) = (addr, addr)" |
    "ipt_iprange_to_interval (IpAddrNetmask pre len) = ipcidr_to_interval (pre, len)" |
    "ipt_iprange_to_interval (IpAddrRange ip1 ip2) = (ip1, ip2)"
  
  lemma ipt_iprange_to_interval: "ipt_iprange_to_interval ip = (s,e)  {s .. e} = ipt_iprange_to_set ip"
    apply(cases ip)
      apply(auto simp add: ipcidr_to_interval)
    done


  text‹A list of IP address ranges to a @{typ "'i::len wordinterval"}.
        The nice thing is: the usual set operations are defined on this type.
        We can use the existing function @{const l2wi_intersect} if we want the intersection of the supplied list›
  lemma "wordinterval_to_set (l2wi_intersect (map ipt_iprange_to_interval ips)) =
            ( ip  set ips. ipt_iprange_to_set ip)"
    apply(simp add: l2wi_intersect)
    using ipt_iprange_to_interval by blast
  
  text‹We can use @{const l2wi} if we want the union of the supplied list›
  lemma "wordinterval_to_set (l2wi (map ipt_iprange_to_interval ips)) = ( ip  set ips. ipt_iprange_to_set ip)"
    apply(simp add: l2wi)
    using ipt_iprange_to_interval by blast

  text‹A list of (negated) IP address to a @{typ "'i::len wordinterval"}.›
  definition ipt_iprange_negation_type_to_br_intersect ::
    "'i::len ipt_iprange negation_type list  'i wordinterval" where
    "ipt_iprange_negation_type_to_br_intersect l = l2wi_negation_type_intersect (NegPos_map ipt_iprange_to_interval l)" 

  lemma ipt_iprange_negation_type_to_br_intersect: "wordinterval_to_set (ipt_iprange_negation_type_to_br_intersect l) =
      ( ip  set (getPos l). ipt_iprange_to_set ip) - ( ip  set (getNeg l). ipt_iprange_to_set ip)"
    apply(simp add: ipt_iprange_negation_type_to_br_intersect_def l2wi_negation_type_intersect NegPos_map_simps)
    using ipt_iprange_to_interval by blast

  text‹The @{typ "'i::len wordinterval"} can be translated back into a list of IP ranges.
        If a list of intervals is enough, we can use @{const wi2l}.
        If we need it in @{typ "'i::len ipt_iprange"}, we can use this function.›
  definition wi_2_cidr_ipt_iprange_list :: "'i::len wordinterval  'i ipt_iprange list" where
    "wi_2_cidr_ipt_iprange_list r = map (uncurry IpAddrNetmask) (cidr_split r)"

  lemma wi_2_cidr_ipt_iprange_list:
    "( ip  set (wi_2_cidr_ipt_iprange_list r). ipt_iprange_to_set ip) = wordinterval_to_set r"
    proof -
    have "( ip  set (wi_2_cidr_ipt_iprange_list r). ipt_iprange_to_set ip) =
           (xset (cidr_split r). uncurry ipset_from_cidr x)"
      unfolding wi_2_cidr_ipt_iprange_list_def by force
    thus ?thesis using cidr_split_prefix by metis
  qed

  text‹For example, this allows the following transformation›
  definition ipt_iprange_compress :: "'i::len ipt_iprange negation_type list  'i ipt_iprange list" where
    "ipt_iprange_compress = wi_2_cidr_ipt_iprange_list  ipt_iprange_negation_type_to_br_intersect"

  lemma ipt_iprange_compress: "( ip  set (ipt_iprange_compress l). ipt_iprange_to_set ip) =
      ( ip  set (getPos l). ipt_iprange_to_set ip) - ( ip  set (getNeg l). ipt_iprange_to_set ip)"
    by (metis wi_2_cidr_ipt_iprange_list comp_apply ipt_iprange_compress_def ipt_iprange_negation_type_to_br_intersect)
  
  definition normalized_cidr_ip :: "'i::len ipt_iprange  bool" where
    "normalized_cidr_ip ip  case ip of IpAddrNetmask _ _  True | _  False"

  lemma wi_2_cidr_ipt_iprange_list_normalized_IpAddrNetmask: 
    "a'set (wi_2_cidr_ipt_iprange_list as). normalized_cidr_ip a'"
    apply(clarify)
    apply(simp add: wi_2_cidr_ipt_iprange_list_def normalized_cidr_ip_def)
    by force

  lemma ipt_iprange_compress_normalized_IpAddrNetmask:
    "a'set (ipt_iprange_compress as). normalized_cidr_ip a'"
    by(simp add: ipt_iprange_compress_def wi_2_cidr_ipt_iprange_list_normalized_IpAddrNetmask)


  
  definition ipt_iprange_to_cidr :: "'i::len ipt_iprange  ('i word × nat) list" where
    "ipt_iprange_to_cidr ips = cidr_split (iprange_interval (ipt_iprange_to_interval ips))"

  lemma ipt_ipvange_to_cidr: "ipcidr_union_set (set (ipt_iprange_to_cidr ips)) = (ipt_iprange_to_set ips)"
    apply(simp add: ipt_iprange_to_cidr_def)
    apply(simp add: ipcidr_union_set_uncurry)
    apply(case_tac "(ipt_iprange_to_interval ips)")
    apply(simp add: ipt_iprange_to_interval cidr_split_prefix_single)
    done
    



(* actually, these are toString pretty printing helpers*)
definition interval_to_wi_to_ipt_iprange :: "'i::len word  'i word  'i ipt_iprange" where
  "interval_to_wi_to_ipt_iprange s e 
    if s = e
    then IpAddr s
    else case cidr_split (WordInterval s e) of [(ip,nmask)]  IpAddrNetmask ip nmask
                                            |   _  IpAddrRange s e"

lemma interval_to_wi_to_ipt_ipv4range: "ipt_iprange_to_set (interval_to_wi_to_ipt_iprange s e) = {s..e}"
  proof -
    from cidr_split_prefix_single[of s e] have
      "cidr_split (WordInterval s e) = [(a, b)]  ipset_from_cidr a b = {s..e}" for a b
        by(simp add: iprange_interval.simps)
    thus ?thesis 
      by(simp add: interval_to_wi_to_ipt_iprange_def split: list.split)
  qed

fun wi_to_ipt_iprange :: "'i::len wordinterval  'i ipt_iprange list" where
  "wi_to_ipt_iprange (WordInterval s e) = (if s > e then [] else 
      [interval_to_wi_to_ipt_iprange s e])" |
  "wi_to_ipt_iprange (RangeUnion a b) = wi_to_ipt_iprange a @ wi_to_ipt_iprange b"

lemma wi_to_ipt_ipv4range: "(set (map ipt_iprange_to_set (wi_to_ipt_iprange wi))) = wordinterval_to_set wi"
  apply(induction wi)
   apply(simp add: interval_to_wi_to_ipt_ipv4range)
  apply(simp)
  done

end

Theory L4_Protocol_Flags

theory L4_Protocol_Flags
imports Simple_Firewall.L4_Protocol
begin

section‹Matching TCP Flags›
  (*man iptables-extensions, [!] --tcp-flags mask comp*)
  datatype ipt_tcp_flags = TCP_Flags "tcp_flag set" ― ‹mask›
                                     "tcp_flag set" ― ‹comp›
  
  (*--syn: Only match TCP packets with the SYN bit set and the ACK,RST and FIN bits cleared. [...] It is equivalent to --tcp-flags SYN,RST,ACK,FIN SYN.*)
  definition ipt_tcp_syn :: "ipt_tcp_flags" where
    "ipt_tcp_syn  TCP_Flags {TCP_SYN,TCP_RST,TCP_ACK,TCP_FIN} {TCP_SYN}"
  
  fun match_tcp_flags :: "ipt_tcp_flags  tcp_flag set  bool" where
     "match_tcp_flags (TCP_Flags fmask c) flags  (flags  fmask) = c"
  
  lemma "match_tcp_flags ipt_tcp_syn {TCP_SYN, TCP_URG, TCP_PSH}" by eval
  
  lemma match_tcp_flags_nomatch: "¬ c  fmask  ¬ match_tcp_flags (TCP_Flags fmask c) pkt" by auto
  
  definition ipt_tcp_flags_NoMatch :: "ipt_tcp_flags" where
    "ipt_tcp_flags_NoMatch  TCP_Flags {} {TCP_SYN}"
  lemma ipt_tcp_flags_NoMatch: "¬ match_tcp_flags ipt_tcp_flags_NoMatch pkt" by(simp add: ipt_tcp_flags_NoMatch_def)
  
  definition ipt_tcp_flags_Any :: ipt_tcp_flags where
    "ipt_tcp_flags_Any  TCP_Flags {} {}"
  lemma ipt_tcp_flags_Any: "match_tcp_flags ipt_tcp_flags_Any pkt" by(simp add: ipt_tcp_flags_Any_def)

  lemma ipt_tcp_flags_Any_isUNIV: "fmask = {}  c = {}  (pkt. match_tcp_flags (TCP_Flags fmask c) pkt)" by auto
  
  fun match_tcp_flags_conjunct :: "ipt_tcp_flags  ipt_tcp_flags  ipt_tcp_flags" where
    "match_tcp_flags_conjunct (TCP_Flags fmask1 c1) (TCP_Flags fmask2 c2) = (
          if c1  fmask1  c2  fmask2  fmask1  fmask2  c1 = fmask1  fmask2  c2
          then (TCP_Flags (fmask1  fmask2) (c1  c2))
          else ipt_tcp_flags_NoMatch)"
  
  lemma match_tcp_flags_conjunct: "match_tcp_flags (match_tcp_flags_conjunct f1 f2) pkt  match_tcp_flags f1 pkt  match_tcp_flags f2 pkt"
    apply(cases f1, cases f2, simp)
    apply(rename_tac fmask1 c1 fmask2 c2)
    apply(intro conjI impI)
     apply(elim conjE)
     apply blast
    apply(simp add: ipt_tcp_flags_NoMatch)
    apply fast
    done
  declare match_tcp_flags_conjunct.simps[simp del]


  text‹Same as @{const match_tcp_flags_conjunct}, but returns @{const None} if result cannot match anyway›
  definition match_tcp_flags_conjunct_option :: "ipt_tcp_flags  ipt_tcp_flags  ipt_tcp_flags option" where
    "match_tcp_flags_conjunct_option f1 f2 = (case match_tcp_flags_conjunct f1 f2 of (TCP_Flags fmask c)  if c  fmask then Some (TCP_Flags fmask c) else None)"

  lemma "match_tcp_flags_conjunct_option ipt_tcp_syn (TCP_Flags {TCP_RST,TCP_ACK} {TCP_RST}) = None" by eval


  lemma match_tcp_flags_conjunct_option_Some: "match_tcp_flags_conjunct_option f1 f2 = Some f3 
      match_tcp_flags f1 pkt  match_tcp_flags f2 pkt  match_tcp_flags f3 pkt"
    apply(simp add: match_tcp_flags_conjunct_option_def split: ipt_tcp_flags.split_asm if_split_asm)
    using match_tcp_flags_conjunct by blast
  lemma match_tcp_flags_conjunct_option_None: "match_tcp_flags_conjunct_option f1 f2 = None 
      ¬(match_tcp_flags f1 pkt  match_tcp_flags f2 pkt)"
    apply(simp add: match_tcp_flags_conjunct_option_def split: ipt_tcp_flags.split_asm if_split_asm)
    using match_tcp_flags_conjunct match_tcp_flags_nomatch by metis

  lemma match_tcp_flags_conjunct_option: "(case match_tcp_flags_conjunct_option f1 f2 of None  False | Some f3  match_tcp_flags f3 pkt)  match_tcp_flags f1 pkt  match_tcp_flags f2 pkt"
    apply(simp split: option.split)
    using match_tcp_flags_conjunct_option_Some match_tcp_flags_conjunct_option_None by blast



  fun ipt_tcp_flags_equal :: "ipt_tcp_flags  ipt_tcp_flags  bool" where
    "ipt_tcp_flags_equal (TCP_Flags fmask1 c1) (TCP_Flags fmask2 c2) = (
          if c1  fmask1  c2  fmask2
          then c1 = c2  fmask1 = fmask2
          else  (¬ c1  fmask1)  (¬ c2  fmask2))"
  context
  begin
    private lemma funny_set_falg_fmask_helper: "c2  fmask2  (c1 = c2  fmask1 = fmask2) = (pkt. (pkt  fmask1 = c1) = (pkt  fmask2 = c2))"
    apply rule
     apply presburger
    apply(subgoal_tac "fmask1 = fmask2")
     apply blast
    (*"e": Try this: by (metis Diff_Compl Diff_eq Int_lower2 Un_Diff_Int compl_sup disjoint_eq_subset_Compl inf_assoc inf_commute inf_sup_absorb) (> 1.0 s, timed out).
      Isar proof (300 ms):*)
    proof -
      assume a1: "c2  fmask2"
      assume a2: "pkt. (pkt  fmask1 = c1) = (pkt  fmask2 = c2)"
      have f3: "A Aa. (A::'a set) - - Aa = Aa - - A"
        by (simp add: inf_commute)
      have f4: "A Aa. (A::'a set) - - (- Aa) = A - Aa"
        by simp
      have f5: "A Aa Ab. (A::'a set) - - Aa - - Ab = A - - (Aa - - Ab)"
        by blast
      have f6: "A Aa. (A::'a set) - (- A - Aa) = A"
        by fastforce
      have f7: "A Aa. - (A::'a set) - - Aa = Aa - A"
        using f4 f3 by presburger
      have f8: "A Aa. - (A::'a set) = - (A - Aa) - (A - - Aa)"
        by blast
      have f9: "c1 = - (- c1)"
        by blast
      have f10: "A. A - c1 - c1 = A - c1"
        by blast
      have "A. A - - (fmask1 - - fmask2) = c2  A - - fmask1  c1"
        using f6 f5 a2 by (metis (no_types) Diff_Compl)
      hence f11: "A. - A - - (fmask1 - - fmask2) = c2  fmask1 - A  c1"
        using f7 by meson
      have "c2 - fmask2 = {}"
        using a1 by force
      hence f12: "- c2 - (fmask2 - c2) = - fmask2"
        by blast
      hence "fmask2 - - c2 = c2"
        by blast
      hence f13: "fmask1 - - c2 = c1"
        using f3 a2 by simp
      hence f14: "c1 = c2"
        using f11 by blast
      hence f15: "fmask2 - (fmask1 - c1) = c1"
        using f13 f10 f9 f8 f7 f3 a2 by (metis Diff_Compl)
      have "fmask1 - (fmask2 - c1) = c1"
        using f14 f12 f10 f9 f8 f4 f3 a2 by (metis Diff_Compl)
      thus "fmask1 = fmask2"
        using f15 by blast
    qed
  
    lemma ipt_tcp_flags_equal: "ipt_tcp_flags_equal f1 f2  (pkt. match_tcp_flags f1 pkt = match_tcp_flags f2 pkt)"
      apply(cases f1, cases f2, simp)
      apply(rename_tac fmask1 c1 fmask2 c2)
      apply(intro conjI impI)
       using funny_set_falg_fmask_helper apply metis
      apply blast
     done
  end
  declare ipt_tcp_flags_equal.simps[simp del]
end

Theory Ports

theory Ports
imports
  "HOL-Library.Word"
  "../Common/WordInterval_Lists"
  L4_Protocol_Flags
begin

section‹Ports (layer 4)›
text‹E.g. source and destination ports for TCP/UDP›

text‹list of (start, end) port ranges›
type_synonym raw_ports = "(16 word × 16 word) list"

fun ports_to_set :: "raw_ports  (16 word) set" where
  "ports_to_set [] = {}" |
  "ports_to_set ((s,e)#ps) = {s..e}  ports_to_set ps"

lemma ports_to_set: "ports_to_set pts =  {{s..e} | s e . (s,e)  set pts}"
  proof(induction pts)
  case Nil thus ?case by simp
  next
  case (Cons p pts) thus ?case by(cases p, simp, blast)
  qed

text‹We can reuse the wordinterval theory to reason about ports›
lemma ports_to_set_wordinterval: "ports_to_set ps = wordinterval_to_set (l2wi ps)"
  by(induction ps rule: l2wi.induct) (auto)


text‹inverting a raw listing of ports›
definition "raw_ports_invert" :: "raw_ports  raw_ports" where
  "raw_ports_invert ps = wi2l (wordinterval_invert (l2wi ps))"

lemma raw_ports_invert: "ports_to_set (raw_ports_invert ps) = - ports_to_set ps"
  by(auto simp add: raw_ports_invert_def l2wi_wi2l ports_to_set_wordinterval)


text‹A port always belongs to a protocol! We must not lose this information.
 You should never use @{typ raw_ports} directly›
datatype ipt_l4_ports = L4Ports primitive_protocol raw_ports


end

Theory Conntrack_State

theory Conntrack_State
imports "../Common/Negation_Type" Simple_Firewall.Lib_Enum_toString
begin


datatype ctstate = CT_New | CT_Established | CT_Related | CT_Untracked | CT_Invalid

text‹The state associated with a packet can be added as a tag to the packet.
      See @{file ‹../Semantics_Stateful.thy›}.›

fun match_ctstate :: "ctstate set  ctstate  bool" where
"match_ctstate S s_tag  s_tag  S"

fun ctstate_conjunct :: "ctstate set  ctstate set  ctstate set option" where
  "ctstate_conjunct S1 S2 = (if S1  S2 = {} then None else Some (S1  S2))"

value[code] "ctstate_conjunct {CT_Established, CT_New} {CT_New}"

lemma ctstate_conjunct_correct: "match_ctstate S1 pkt  match_ctstate S2 pkt  
  (case ctstate_conjunct S1 S2 of None  False | Some S'  match_ctstate S' pkt)"
  apply simp
  by blast

lemma UNIV_ctstate: "UNIV = {CT_New, CT_Established, CT_Related, CT_Untracked, CT_Invalid}" using ctstate.exhaust by auto 

(*
function ctstate_set_toString_list :: "ctstate set ⇒ string list" where
  "ctstate_set_toString_list S = (if S = {} then [] else
    if CT_New ∈ S then ''NEW''#ctstate_set_toString_list (S - {CT_New}) else
    if CT_Established ∈ S then ''ESTABLISHED''#ctstate_set_toString_list (S - {CT_Established}) else
    if CT_Related ∈ S then ''RELATED''#ctstate_set_toString_list (S - {CT_Related}) else
    if CT_Untracked ∈ S then ''UNTRACKED''#ctstate_set_toString_list (S - {CT_Untracked}) else [''ERROR-unkown-ctstate''])"
by(pat_completeness) auto

termination ctstate_set_toString_list
  apply(relation "measure (λ(S). card S)")
  apply(simp_all add: card_gt_0_iff)
  done

*)
instance ctstate :: finite
proof
  from UNIV_ctstate show "finite (UNIV:: ctstate set)" using finite.simps by auto 
qed

  
lemma "finite (S :: ctstate set)" by simp


instantiation "ctstate" :: enum
begin
  definition "enum_ctstate = [CT_New, CT_Established, CT_Related, CT_Untracked, CT_Invalid]"

  definition "enum_all_ctstate P  P CT_New  P CT_Established  P CT_Related  P CT_Untracked  P CT_Invalid"
  
  definition "enum_ex_ctstate P  P CT_New  P CT_Established  P CT_Related  P CT_Untracked  P CT_Invalid"
instance proof
  show "UNIV = set (enum_class.enum :: ctstate list)"
    by(simp add: UNIV_ctstate enum_ctstate_def)
  next
  show "distinct (enum_class.enum :: ctstate list)"
    by(simp add: enum_ctstate_def)
  next
  show "P. (enum_class.enum_all :: (ctstate  bool)  bool) P = Ball UNIV P"
    by(simp add: UNIV_ctstate enum_all_ctstate_def)
  next
  show "P. (enum_class.enum_ex :: (ctstate  bool)  bool) P = Bex UNIV P"
    by(simp add: UNIV_ctstate enum_ex_ctstate_def)
qed
end

definition ctstate_is_UNIV :: "ctstate set  bool" where
  "ctstate_is_UNIV c  CT_New  c  CT_Established  c  CT_Related  c  CT_Untracked  c  CT_Invalid  c"

lemma ctstate_is_UNIV: "ctstate_is_UNIV c  c = UNIV"
  unfolding ctstate_is_UNIV_def
  apply(simp add: UNIV_ctstate)
  apply(rule iffI)
  apply(clarify)
   using UNIV_ctstate apply fastforce
   apply(simp)
  done


value[code] "ctstate_is_UNIV {CT_Established}"



fun ctstate_toString :: "ctstate  string" where
  "ctstate_toString CT_New = ''NEW''" |
  "ctstate_toString CT_Established = ''ESTABLISHED''" |
  "ctstate_toString CT_Related = ''RELATED''" |
  "ctstate_toString CT_Untracked = ''UNTRACKED''" |
  "ctstate_toString CT_Invalid = ''INVALID''"


definition ctstate_set_toString :: "ctstate set  string" where
  "ctstate_set_toString S = list_separated_toString '','' ctstate_toString (enum_set_to_list S)"

lemma "ctstate_set_toString {CT_New, CT_New, CT_Established} = ''NEW,ESTABLISHED''" by eval


end

Theory Tagged_Packet

theory Tagged_Packet
imports Simple_Firewall.Simple_Packet Conntrack_State
begin

section‹Tagged Simple Packet›
  text‹Packet constants are prefixed with p›

  text‹A packet tagged with the following phantom fields:
             conntrack connection state›

  text‹The idea to tag the connection state into the packet is sound.
       See @{file ‹../Semantics_Stateful.thy›}

  record (overloaded) 'i tagged_packet = "'i::len simple_packet" +
                         p_tag_ctstate :: ctstate


  value " 
          p_iiface = ''eth1'', p_oiface = '''', 
          p_src = 0, p_dst = 0, 
          p_proto = TCP, p_sport = 0, p_dport = 0, 
          p_tcp_flags = {TCP_SYN},
          p_payload = ''arbitrary payload'',
          p_tag_ctstate = CT_New
         :: 32 tagged_packet"

  definition simple_packet_tag
    :: "ctstate  ('i::len, 'a) simple_packet_scheme  ('i::len, 'a) tagged_packet_scheme" where
    "simple_packet_tag ct_state p 
      p_iiface = p_iiface p, p_oiface = p_oiface p, p_src = p_src p, p_dst = p_dst p, p_proto = p_proto p, 
       p_sport = p_sport p, p_dport = p_dport p, p_tcp_flags = p_tcp_flags p, 
       p_payload = p_payload p,
       p_tag_ctstate = ct_state,
        = simple_packet.more p"

  definition tagged_packet_untag
    :: "('i::len, 'a) tagged_packet_scheme  ('i::len, 'a) simple_packet_scheme" where
    "tagged_packet_untag p 
      p_iiface = p_iiface p, p_oiface = p_oiface p, p_src = p_src p, p_dst = p_dst p, p_proto = p_proto p, 
       p_sport = p_sport p, p_dport = p_dport p, p_tcp_flags = p_tcp_flags p, 
       p_payload = p_payload p,
        = tagged_packet.more p"

  lemma "tagged_packet_untag (simple_packet_tag ct_state p) = p"
        "simple_packet_tag ct_state (tagged_packet_untag p) = pp_tag_ctstate := ct_state"
    apply(case_tac [!] p)
     by(simp add: tagged_packet_untag_def simple_packet_tag_def)+
    

end

Theory Common_Primitive_Syntax

theory Common_Primitive_Syntax
imports "../Datatype_Selectors"
        IpAddresses
        Simple_Firewall.Iface
        L4_Protocol_Flags Ports Tagged_Packet Conntrack_State
begin

section‹Primitive Matchers: Interfaces, IP Space, Layer 4 Ports Matcher›

text‹Primitive Match Conditions which only support interfaces, IPv4 addresses,  layer 4 protocols, and layer 4 ports.
›


context
  notes [[typedef_overloaded]]
begin
  datatype 'i common_primitive =
    is_Src: Src (src_sel: "'i::len ipt_iprange") | 
    is_Dst: Dst (dst_sel: "'i::len ipt_iprange") |
    is_Iiface: IIface (iiface_sel: iface) |
    is_Oiface: OIface (oiface_sel: iface) |
    is_Prot: Prot (prot_sel: protocol) | 
    is_Src_Ports: Src_Ports (src_ports_sel: ipt_l4_ports) |
    is_Dst_Ports: Dst_Ports (dst_ports_sel: ipt_l4_ports) |
    is_MultiportPorts: MultiportPorts (multiportports_sel: ipt_l4_ports) |
    is_L4_Flags: L4_Flags (l4_flags_sel: ipt_tcp_flags) |
    is_CT_State: CT_State (ct_state_sel: "ctstate set") |
    is_Extra: Extra (extra_sel: string)
end


lemma wf_disc_sel_common_primitive: 
      "wf_disc_sel (is_Src_Ports, src_ports_sel) Src_Ports"
      "wf_disc_sel (is_Dst_Ports, dst_ports_sel) Dst_Ports"
      "wf_disc_sel (is_Src, src_sel) Src"
      "wf_disc_sel (is_Dst, dst_sel) Dst"
      "wf_disc_sel (is_Iiface, iiface_sel) IIface"
      "wf_disc_sel (is_Oiface, oiface_sel) OIface"
      "wf_disc_sel (is_Prot, prot_sel) Prot"
      "wf_disc_sel (is_L4_Flags, l4_flags_sel) L4_Flags"
      "wf_disc_sel (is_CT_State, ct_state_sel) CT_State"
      "wf_disc_sel (is_Extra, extra_sel) Extra"
      "wf_disc_sel (is_MultiportPorts, multiportports_sel) MultiportPorts"
  by(simp_all add: wf_disc_sel.simps)


  ― ‹Example for a packet again:›
  value "p_iiface = ''eth0'', p_oiface = ''eth1'',
          p_src = ipv4addr_of_dotdecimal (192,168,2,45), p_dst= ipv4addr_of_dotdecimal (173,194,112,111),
          p_proto=TCP, p_sport=2065, p_dport=80, p_tcp_flags = {TCP_ACK},
          p_payload = ''GET / HTTP/1.0'',
          p_tag_ctstate = CT_Established :: 32 tagged_packet"




end

Theory Unknown_Match_Tacs

theory Unknown_Match_Tacs
imports Matching_Ternary
begin

section‹Approximate Matching Tactics›
text‹in-doubt-tactics›

fun in_doubt_allow :: "'packet unknown_match_tac" where
  "in_doubt_allow Accept _ = True" |
  "in_doubt_allow Drop _ = False" |
  "in_doubt_allow Reject _ = False" |
  "in_doubt_allow _ _ = undefined"
  (*Call/Return must not appear*)
  (*call rm_LogEmpty first. Log/Empty must not appear here*)
  (*give it a simple_ruleset*)

lemma wf_in_doubt_allow: "wf_unknown_match_tac in_doubt_allow"
  unfolding wf_unknown_match_tac_def by(simp add: fun_eq_iff)



fun in_doubt_deny :: "'packet unknown_match_tac" where
  "in_doubt_deny Accept _ = False" |
  "in_doubt_deny Drop _ = True" |
  "in_doubt_deny Reject _ = True" |
  "in_doubt_deny _ _ = undefined"
  (*Call/Return must not appear*)
  (*call rm_LogEmpty first. Log/Empty must not appear here*)
  (*give it a simple_ruleset*)

lemma wf_in_doubt_deny: "wf_unknown_match_tac in_doubt_deny"
  unfolding wf_unknown_match_tac_def by(simp add: fun_eq_iff)

lemma packet_independent_unknown_match_tacs:
    "packet_independent_α in_doubt_allow"
    "packet_independent_α in_doubt_deny"
  by(simp_all add: packet_independent_α_def)


lemma Drop_neq_Accept_unknown_match_tacs:
      "in_doubt_allow Drop  in_doubt_allow Accept"
      "in_doubt_deny Drop  in_doubt_deny Accept"
  by(simp_all add: fun_eq_iff)



(* use this more often to simplify existing proofs? *)
corollary matches_induction_case_MatchNot_in_doubt_allow:
      " a. matches (β,in_doubt_allow) m' a p = matches (β,in_doubt_allow) m a p 
      matches (β,in_doubt_allow) (MatchNot m') a p = matches (β,in_doubt_allow) (MatchNot m) a p"
  by(rule  matches_induction_case_MatchNot) (simp_all add: Drop_neq_Accept_unknown_match_tacs packet_independent_unknown_match_tacs)
corollary matches_induction_case_MatchNot_in_doubt_deny:
      " a. matches (β,in_doubt_deny) m' a p = matches (β,in_doubt_deny) m a p 
      matches (β,in_doubt_deny) (MatchNot m') a p = matches (β,in_doubt_deny) (MatchNot m) a p"
  by(rule  matches_induction_case_MatchNot) (simp_all add: Drop_neq_Accept_unknown_match_tacs packet_independent_unknown_match_tacs)

end

Theory Common_Primitive_Matcher_Generic

theory Common_Primitive_Matcher_Generic
imports "../Semantics_Ternary/Semantics_Ternary"
        Common_Primitive_Syntax
        "../Semantics_Ternary/Unknown_Match_Tacs"
begin


subsection‹A Generic primitive matcher: Agnostic of IP Addresses›

text‹Generalized Definition agnostic of IP Addresses fro IPv4 and IPv6›


(*generic assumptions for a common matcher without information about IPs.
  used to add ipv6 integration without duplicating all proofs *)
locale primitive_matcher_generic =
  fixes β :: "('i::len common_primitive, ('i::len, 'a) tagged_packet_scheme) exact_match_tac"
  assumes IIface: " p i. β (IIface i) p = bool_to_ternary (match_iface i (p_iiface p))"
      and OIface: " p i. β (OIface i) p = bool_to_ternary (match_iface i (p_oiface p))"
        and Prot: " p proto. β (Prot proto) p = bool_to_ternary (match_proto proto (p_proto p))"
   and Src_Ports: " p proto ps. β (Src_Ports (L4Ports proto ps)) p = bool_to_ternary (proto = p_proto p  p_sport p  ports_to_set ps)"
   and Dst_Ports: " p proto ps. β (Dst_Ports (L4Ports proto ps)) p = bool_to_ternary (proto = p_proto p  p_dport p  ports_to_set ps)"
   ― ‹-m multiport --ports matches source or destination port›
   and MultiportsPorts: " p proto ps. β (MultiportPorts (L4Ports proto ps)) p = bool_to_ternary (proto = p_proto p  (p_sport p  ports_to_set ps  p_dport p  ports_to_set ps))"
    and L4_Flags: " p flags. β (L4_Flags flags) p = bool_to_ternary (match_tcp_flags flags (p_tcp_flags p))"
    and CT_State: " p S. β (CT_State S) p = bool_to_ternary (match_ctstate S (p_tag_ctstate p))"
        and Extra: " p str. β (Extra str) p = TernaryUnknown"
begin
  lemma Iface_single:
    "matches (β, α) (Match (IIface X)) a p  match_iface X (p_iiface p)"
    "matches (β, α) (Match (OIface X)) a p  match_iface X (p_oiface p)"
     by(simp_all add: IIface OIface match_raw_ternary bool_to_ternary_simps
               split: ternaryvalue.split)
  text‹Since matching on the iface cannot be @{const TernaryUnknown}*, we can pull out negations.›
  lemma Iface_single_not:
    "matches (β, α) (MatchNot (Match (IIface X))) a p  ¬ match_iface X (p_iiface p)"
    "matches (β, α) (MatchNot (Match (OIface X))) a p  ¬ match_iface X (p_oiface p)"
     by(simp_all add: IIface OIface matches_case_ternaryvalue_tuple bool_to_ternary_simps
          split: ternaryvalue.split)

  lemma Prot_single:
    "matches (β, α) (Match (Prot X)) a p  match_proto X (p_proto p)"
     by(simp add: Prot match_raw_ternary bool_to_ternary_simps split: ternaryvalue.split)
  lemma Prot_single_not:
    "matches (β, α) (MatchNot (Match (Prot X))) a p  ¬ match_proto X (p_proto p)"
     by(simp add: Prot matches_case_ternaryvalue_tuple bool_to_ternary_simps split: ternaryvalue.split)

  lemma Ports_single:
    "matches (β, α) (Match (Src_Ports (L4Ports proto ps))) a p  proto = p_proto p  p_sport p  ports_to_set ps"
    "matches (β, α) (Match (Dst_Ports (L4Ports proto ps))) a p  proto = p_proto p  p_dport p  ports_to_set ps"
     by(simp_all add: Src_Ports Dst_Ports match_raw_ternary bool_to_ternary_simps
               split: ternaryvalue.split)
  lemma Ports_single_not:
    "matches (β, α) (MatchNot (Match (Src_Ports (L4Ports proto ps)))) a p  proto  p_proto p  p_sport p  ports_to_set ps"
    "matches (β, α) (MatchNot (Match (Dst_Ports (L4Ports proto ps)))) a p  proto  p_proto p  p_dport p  ports_to_set ps"
     by(simp_all add: Src_Ports Dst_Ports matches_case_ternaryvalue_tuple bool_to_ternary_simps
               split: ternaryvalue.split)

  text‹Ports are dependent matches. They always match on the protocol too›
  lemma Ports_single_rewrite_Prot:
    "matches (β, α) (Match (Src_Ports (L4Ports proto ps))) a p 
      matches (β, α) (Match (Prot (Proto proto))) a p  p_sport p  ports_to_set ps"
    "matches (β, α) (MatchNot (Match (Src_Ports (L4Ports proto ps)))) a p 
      matches (β, α) (MatchNot (Match (Prot (Proto proto)))) a p  p_sport p  ports_to_set ps"
    "matches (β, α) (Match (Dst_Ports (L4Ports proto ps))) a p 
      matches (β, α) (Match (Prot (Proto proto))) a p  p_dport p  ports_to_set ps"
    "matches (β, α) (MatchNot (Match (Dst_Ports (L4Ports proto ps)))) a p 
      matches (β, α) (MatchNot (Match (Prot (Proto proto)))) a p  p_dport p  ports_to_set ps"
  by(auto simp add: Ports_single_not Ports_single Prot_single_not Prot_single)


  lemma multiports_disjuction:
        "(rgset spts. matches (β, α) (Match (Src_Ports (L4Ports proto [rg]))) a p)  matches (β, α) (Match (Src_Ports (L4Ports proto spts))) a p"
        "(rgset dpts. matches (β, α) (Match (Dst_Ports (L4Ports proto [rg]))) a p)  matches (β, α) (Match (Dst_Ports (L4Ports proto dpts))) a p"
    by(auto simp add: Src_Ports Dst_Ports match_raw_ternary bool_to_ternary_simps ports_to_set
                   split: ternaryvalue.split)

  lemma MultiportPorts_single_rewrite:
    "matches (β, α) (Match (MultiportPorts ports)) a p 
      matches (β, α) (Match (Src_Ports ports)) a p  matches (β, α) (Match (Dst_Ports ports)) a p"
    apply(cases ports)
    apply(simp add: Ports_single)
    by(simp add: MultiportsPorts match_raw_ternary bool_to_ternary_simps
            split: ternaryvalue.split)
  lemma MultiportPorts_single_rewrite_MatchOr:
    "matches (β, α) (Match (MultiportPorts ports)) a p 
      matches (β, α) (MatchOr (Match (Src_Ports ports)) (Match (Dst_Ports ports))) a p"
    apply(cases ports)
    by(simp add: MatchOr MultiportPorts_single_rewrite)

  lemma MultiportPorts_single_not_rewrite_MatchAnd:
    "matches (β, α) (MatchNot (Match (MultiportPorts ports))) a p 
      matches (β, α) (MatchAnd (MatchNot (Match (Src_Ports ports))) (MatchNot (Match (Dst_Ports ports)))) a p"
    apply(cases ports)
    apply(simp add: Ports_single_not bunch_of_lemmata_about_matches)
    by(simp add: MultiportsPorts matches_case_ternaryvalue_tuple bool_to_ternary_simps
            split: ternaryvalue.split)
  lemma MultiportPorts_single_not_rewrite:
    "matches (β, α) (MatchNot (Match (MultiportPorts ports))) a p 
      ¬ matches (β, α) (Match (Src_Ports ports)) a p  ¬ matches (β, α) (Match (Dst_Ports ports)) a p"
    apply(cases ports)
    by(simp add: MultiportPorts_single_not_rewrite_MatchAnd bunch_of_lemmata_about_matches
                 Ports_single_not Ports_single)


  lemma Extra_single:
    "matches (β, α) (Match (Extra str)) a p  α a p"
     by(simp add: Extra match_raw_ternary)
  lemma Extra_single_not:  ― ‹ternary logic, @{text "¬ unknown = unknown"}
    "matches (β, α) (MatchNot (Match (Extra str))) a p  α a p"
     by(simp add: Extra matches_case_ternaryvalue_tuple)
end





subsection‹Basic optimisations›
  
  (*this is currently not used.*)
  text‹Compress many @{const Extra} expressions to one expression.›
  fun compress_extra :: "'i::len common_primitive match_expr  'i common_primitive match_expr" where
    "compress_extra (Match x) = Match x" |
    "compress_extra (MatchNot (Match (Extra e))) = Match (Extra (''NOT (''@e@'')''))" |
    "compress_extra (MatchNot m) = (MatchNot (compress_extra m))" |
    (*"compress_extra (MatchAnd (Match (Extra e1)) (Match (Extra e2))) = compress_extra (Match (Extra (e1@'' ''@e2)))" |*)
    (*"compress_extra (MatchAnd (Match (Extra e1)) MatchAny) = Match (Extra e1)" |*)
    "compress_extra (MatchAnd (Match (Extra e1)) m2) = (case compress_extra m2 of Match (Extra e2)  Match (Extra (e1@'' ''@e2)) | MatchAny  Match (Extra e1) | m2'  MatchAnd (Match (Extra e1)) m2')" |
    "compress_extra (MatchAnd m1 m2) = MatchAnd (compress_extra m1) (compress_extra m2)" |
    (*"compress_extra (MatchAnd m1 m2) = (case (compress_extra m1, compress_extra m2) of 
          (Match (Extra e1), Match (Extra e2)) ⇒ Match (Extra (e1@'' ''@e2))
        | (Match (Extra e1), MatchAny) ⇒ Match (Extra e1)
        | (MatchAny, Match (Extra e2)) ⇒ Match (Extra e2)
        | (m1', m2') ⇒ MatchAnd m1' m2')" |*)
    "compress_extra MatchAny = MatchAny"
  
  thm compress_extra.simps
  
  value [nbe] "compress_extra (MatchAnd (Match (Extra ''foo'')) (Match (Extra ''bar'')))"
  value [nbe] "compress_extra (MatchAnd (Match (Extra ''foo'')) (MatchNot (Match (Extra ''bar''))))"
  value [nbe] "compress_extra (MatchAnd (Match (Extra ''-m'')) (MatchAnd (Match (Extra ''addrtype'')) (MatchAnd (Match (Extra ''--dst-type'')) (MatchAnd (Match (Extra ''BROADCAST'')) MatchAny))))"
  
  lemma compress_extra_correct_matchexpr:
    fixes β::"('i::len common_primitive, ('i::len, 'a) tagged_packet_scheme) exact_match_tac"
    assumes generic: "primitive_matcher_generic β"
    shows "matches (β, α) m = matches (β, α) (compress_extra m)"
    proof(simp add: fun_eq_iff, clarify, rename_tac a p)
      fix a and p :: "('i, 'a) tagged_packet_scheme"
      from generic have "β (Extra e) p = TernaryUnknown" for e by(simp add: primitive_matcher_generic.Extra)
      hence "ternary_ternary_eval (map_match_tac β p m) = ternary_ternary_eval (map_match_tac β p (compress_extra m))"
        proof(induction m rule: compress_extra.induct)
        case 4 thus ?case
          by(simp_all split: match_expr.split match_expr.split_asm common_primitive.split)
        qed (simp_all)
      thus "matches (β, α) m a p = matches (β, α) (compress_extra m) a p"
        by(rule matches_iff_apply_f)
      qed

end

Theory Common_Primitive_Matcher

theory Common_Primitive_Matcher
imports Common_Primitive_Matcher_Generic
begin


subsection‹Primitive Matchers: IP Port Iface Matcher›

(*IPv4 matcher*)
fun common_matcher :: "('i::len common_primitive, ('i, 'a) tagged_packet_scheme) exact_match_tac" where
  "common_matcher (IIface i) p = bool_to_ternary (match_iface i (p_iiface p))" |
  "common_matcher (OIface i) p = bool_to_ternary (match_iface i (p_oiface p))" |

  "common_matcher (Src ip) p = bool_to_ternary (p_src p  ipt_iprange_to_set ip)" |
  "common_matcher (Dst ip) p = bool_to_ternary (p_dst p  ipt_iprange_to_set ip)" |

  "common_matcher (Prot proto) p = bool_to_ternary (match_proto proto (p_proto p))" |

  "common_matcher (Src_Ports (L4Ports proto ps)) p = bool_to_ternary (proto = p_proto p  p_sport p  ports_to_set ps)" |
  "common_matcher (Dst_Ports (L4Ports proto ps)) p = bool_to_ternary (proto = p_proto p  p_dport p  ports_to_set ps)" |

  "common_matcher (MultiportPorts (L4Ports proto ps)) p = bool_to_ternary (proto = p_proto p  (p_sport p  ports_to_set ps  p_dport p  ports_to_set ps))" |

  "common_matcher (L4_Flags flags) p = bool_to_ternary (match_tcp_flags flags (p_tcp_flags p))" |

  "common_matcher (CT_State S) p = bool_to_ternary (match_ctstate S (p_tag_ctstate p))" |

  "common_matcher (Extra _) p = TernaryUnknown"



lemma packet_independent_β_unknown_common_matcher: "packet_independent_β_unknown common_matcher"
  apply(simp add: packet_independent_β_unknown_def)
  apply(clarify)
  apply(rename_tac a p1 p2)
  apply(case_tac a)
             apply(simp_all add: bool_to_ternary_Unknown)
     apply(rename_tac l4ports, case_tac l4ports; simp add: bool_to_ternary_Unknown; fail)+
  done

lemma primitive_matcher_generic_common_matcher: "primitive_matcher_generic common_matcher"
  by unfold_locales  simp_all

  (* What if we specify a port range where the start port is greater than the end port?
    For example, mathematically, {3 .. 2} = {}. Does iptables have the same behavior?
    For example, --source-port 1:0 raises an error on my system. For normal port specification, -m tcp, and -m multiport.
    There is also a manpage which states "if the first port is greater than the second one they will be swapped."
    I also saw a system where such an empty port range (--source-port 1:0) was really this impossible range and caused a rule that could never match.
    Because ∄ port. port ∈ {}.
    The behaviour if the end of the port range is smaller than the start is not 100% consistent among iptables versions and different modules.
    In general, it would be best to raise an error if such a range occurs.
    *)

  text‹Warning: beware of the sloppy term `empty' portrange›
  text‹An `empty' port range means it can never match! Basically, @{term "MatchNot (Match (Src_Ports (L4Ports proto [(0,65535)])))"} is False›
  lemma "¬ matches (common_matcher, α) (MatchNot (Match (Src_Ports (L4Ports TCP [(0,65535)])))) a 
          p_iiface = ''eth0'', p_oiface = ''eth1'',
           p_src = ipv4addr_of_dotdecimal (192,168,2,45), p_dst= ipv4addr_of_dotdecimal (173,194,112,111),
           p_proto=TCP, p_sport=2065, p_dport=80, p_tcp_flags = {},
           p_payload = '''', p_tag_ctstate = CT_New"
       by(simp add: primitive_matcher_generic_common_matcher primitive_matcher_generic.Ports_single_not)
  text‹An `empty' port range means it always matches! Basically, @{term "(MatchNot (Match (Src_Ports (L4Ports any []))))"} is True.
        This corresponds to firewall behavior, but usually you cannot specify an empty portrange in firewalls, but omission of portrange means no-port-restrictions, 
        i.e. every port matches.›
  lemma "matches (common_matcher, α) (MatchNot (Match (Src_Ports (L4Ports any [])))) a 
          p_iiface = ''eth0'', p_oiface = ''eth1'',
           p_src = ipv4addr_of_dotdecimal (192,168,2,45), p_dst= ipv4addr_of_dotdecimal (173,194,112,111),
           p_proto=TCP, p_sport=2065, p_dport=80, p_tcp_flags = {},
           p_payload = '''', p_tag_ctstate = CT_New"
       by(simp add: primitive_matcher_generic_common_matcher primitive_matcher_generic.Ports_single_not)
  text‹If not a corner case, portrange matching is straight forward.›
  lemma "matches (common_matcher, α) (Match (Src_Ports (L4Ports TCP [(1024,4096), (9999, 65535)]))) a 
          p_iiface = ''eth0'', p_oiface = ''eth1'',
           p_src = ipv4addr_of_dotdecimal (192,168,2,45), p_dst= ipv4addr_of_dotdecimal (173,194,112,111),
           p_proto=TCP, p_sport=2065, p_dport=80, p_tcp_flags = {},
           p_payload = '''', p_tag_ctstate = CT_New"
        "¬ matches (common_matcher, α) (Match (Src_Ports (L4Ports TCP [(1024,4096), (9999, 65535)]))) a 
          p_iiface = ''eth0'', p_oiface = ''eth1'',
           p_src = ipv4addr_of_dotdecimal (192,168,2,45), p_dst= ipv4addr_of_dotdecimal (173,194,112,111),
           p_proto=TCP, p_sport=5000, p_dport=80, p_tcp_flags = {},
           p_payload = '''', p_tag_ctstate = CT_New"
        "¬matches (common_matcher, α) (MatchNot (Match (Src_Ports (L4Ports TCP [(1024,4096), (9999, 65535)])))) a 
          p_iiface = ''eth0'', p_oiface = ''eth1'',
           p_src = ipv4addr_of_dotdecimal (192,168,2,45), p_dst= ipv4addr_of_dotdecimal (173,194,112,111),
           p_proto=TCP, p_sport=2065, p_dport=80, p_tcp_flags = {},
           p_payload = '''', p_tag_ctstate = CT_New"
       by(simp_all add: primitive_matcher_generic_common_matcher primitive_matcher_generic.Ports_single_not primitive_matcher_generic.Ports_single)
  



text‹Lemmas when matching on @{term Src} or @{term Dst}
lemma common_matcher_SrcDst_defined:
  "common_matcher (Src m) p  TernaryUnknown"
  "common_matcher (Dst m) p  TernaryUnknown"
  "common_matcher (Src_Ports ps) p  TernaryUnknown"
  "common_matcher (Dst_Ports ps) p  TernaryUnknown"
  "common_matcher (MultiportPorts ps) p  TernaryUnknown"
  apply(case_tac [!] m, case_tac [!] ps)
  apply(simp_all add: bool_to_ternary_Unknown)
  done
lemma common_matcher_SrcDst_defined_simp:
  "common_matcher (Src x) p  TernaryFalse  common_matcher (Src x) p = TernaryTrue"
  "common_matcher (Dst x) p  TernaryFalse  common_matcher (Dst x) p = TernaryTrue"
apply (metis eval_ternary_Not.cases common_matcher_SrcDst_defined(1) ternaryvalue.distinct(1))
apply (metis eval_ternary_Not.cases common_matcher_SrcDst_defined(2) ternaryvalue.distinct(1))
done

(*The primitive_matcher_generic does not know anything about IP addresses*)
lemma match_simplematcher_SrcDst:
  "matches (common_matcher, α) (Match (Src X)) a p  p_src  p  ipt_iprange_to_set X"
  "matches (common_matcher, α) (Match (Dst X)) a p  p_dst  p  ipt_iprange_to_set X"
   by(simp_all add: match_raw_ternary bool_to_ternary_simps split: ternaryvalue.split)
lemma match_simplematcher_SrcDst_not:
  "matches (common_matcher, α) (MatchNot (Match (Src X))) a p  p_src  p  ipt_iprange_to_set X"
  "matches (common_matcher, α) (MatchNot (Match (Dst X))) a p  p_dst  p  ipt_iprange_to_set X"
   apply(simp_all add: matches_case_ternaryvalue_tuple split: ternaryvalue.split)
   apply(case_tac [!] X)
   apply(simp_all add: bool_to_ternary_simps)
   done
lemma common_matcher_SrcDst_Inter:
  "(mset X. matches (common_matcher, α) (Match (Src m)) a p)  p_src p  (xset X. ipt_iprange_to_set x)"
  "(mset X. matches (common_matcher, α) (Match (Dst m)) a p)  p_dst p  (xset X. ipt_iprange_to_set x)"
  by(simp_all add: match_raw_ternary bool_to_ternary_simps split: ternaryvalue.split)





subsection‹Basic optimisations›
  text‹Perform very basic optimization. Remove matches to primitives which are essentially @{const MatchAny}
  fun optimize_primitive_univ :: "'i::len common_primitive match_expr  'i common_primitive match_expr" where
    "optimize_primitive_univ (Match (Src (IpAddrNetmask _ 0))) = MatchAny" |
    "optimize_primitive_univ (Match (Dst (IpAddrNetmask _ 0))) = MatchAny" |
    (*missing: the other IPs ...*)
    "optimize_primitive_univ (Match (IIface iface)) = (if iface = ifaceAny then MatchAny else (Match (IIface iface)))" |
    "optimize_primitive_univ (Match (OIface iface)) = (if iface = ifaceAny then MatchAny else (Match (OIface iface)))" |
    (*missing: L4Ports. But this introduces a new match, which causes problems.
    "optimize_primitive_univ (Match (Src_Ports (L4Ports proto [(s, e)]))) = (if s = 0 ∧ e = 0xFFFF then (Match (Prot (Proto proto))) else (Match (Src_Ports (L4Ports proto [(s, e)]))))" |
    "optimize_primitive_univ (Match (Dst_Ports (L4Ports proto [(s, e)]))) = (if s = 0 ∧ e = 0xFFFF then (Match (Prot (Proto proto))) else (Match (Dst_Ports (L4Ports proto [(s, e)]))))" |*)
    "optimize_primitive_univ (Match (Prot ProtoAny)) = MatchAny" |
    "optimize_primitive_univ (Match (L4_Flags (TCP_Flags m c))) = (if m = {}  c = {} then MatchAny else (Match (L4_Flags (TCP_Flags m c))))" |
    "optimize_primitive_univ (Match (CT_State ctstate)) = (if ctstate_is_UNIV ctstate then MatchAny else Match (CT_State ctstate))" |
    "optimize_primitive_univ (Match m) = Match m" |
    (*"optimize_primitive_univ (MatchNot (MatchNot m)) = (optimize_primitive_univ m)" | --"needed to preserve normalized condition"*)
    "optimize_primitive_univ (MatchNot m) = (MatchNot (optimize_primitive_univ m))" |
    (*"optimize_primitive_univ (MatchAnd (Match (Extra e1)) (Match (Extra e2))) = optimize_primitive_univ (Match (Extra (e1@'' ''@e2)))" |
      -- "can be done but normalization does not work afterwards"*)
    "optimize_primitive_univ (MatchAnd m1 m2) = MatchAnd (optimize_primitive_univ m1) (optimize_primitive_univ m2)" |
    "optimize_primitive_univ MatchAny = MatchAny"

    lemma optimize_primitive_univ_unchanged_primitives:
    "optimize_primitive_univ (Match a) = (Match a)  optimize_primitive_univ (Match a) = MatchAny"
      by (induction "(Match a)" rule: optimize_primitive_univ.induct)
         (auto split: if_split_asm)
    
  
  lemma optimize_primitive_univ_correct_matchexpr: fixes m::"'i::len common_primitive match_expr"
    shows "matches (common_matcher, α) m = matches (common_matcher, α) (optimize_primitive_univ m)"
    proof(simp add: fun_eq_iff, clarify, rename_tac a p)
      fix a and p :: "('i::len, 'a) tagged_packet_scheme"
      have "65535 = (max_word::16 word)" by simp
      then have port_range: "s e port. s = 0  e = 0xFFFF  (port::16 word)  0xFFFF"
        by (simp only:) simp
      have "ternary_ternary_eval (map_match_tac common_matcher p m) = ternary_ternary_eval (map_match_tac common_matcher p (optimize_primitive_univ m))"
        apply(induction m rule: optimize_primitive_univ.induct)
                               by(simp_all add: port_range match_ifaceAny ipset_from_cidr_0 ctstate_is_UNIV)
         (*by(fastforce intro: arg_cong[where f=bool_to_ternary])+ if we add pots again*)
      thus "matches (common_matcher, α) m a p = matches (common_matcher, α) (optimize_primitive_univ m) a p"
        by(rule matches_iff_apply_f)
      qed
  
  corollary optimize_primitive_univ_correct: "approximating_bigstep_fun (common_matcher, α) p (optimize_matches optimize_primitive_univ rs) s = 
                                              approximating_bigstep_fun (common_matcher, α) p rs s"
  using optimize_matches optimize_primitive_univ_correct_matchexpr by metis
  
  
subsection‹Abstracting over unknowns›
  text‹remove @{const Extra} (i.e. @{const TernaryUnknown}) match expressions›
  fun upper_closure_matchexpr :: "action  'i::len common_primitive match_expr  'i common_primitive match_expr" where
    "upper_closure_matchexpr _ MatchAny = MatchAny" |
    "upper_closure_matchexpr Accept (Match (Extra _)) = MatchAny" |
    "upper_closure_matchexpr Reject (Match (Extra _)) = MatchNot MatchAny" |
    "upper_closure_matchexpr Drop (Match (Extra _)) = MatchNot MatchAny" |
    "upper_closure_matchexpr _ (Match m) = Match m" |
    "upper_closure_matchexpr Accept (MatchNot (Match (Extra _))) = MatchAny" |
    "upper_closure_matchexpr Drop (MatchNot (Match (Extra _))) = MatchNot MatchAny" |
    "upper_closure_matchexpr Reject (MatchNot (Match (Extra _))) = MatchNot MatchAny" |
    "upper_closure_matchexpr a (MatchNot (MatchNot m)) = upper_closure_matchexpr a m" |
    "upper_closure_matchexpr a (MatchNot (MatchAnd m1 m2)) = 
      (let m1' = upper_closure_matchexpr a (MatchNot m1); m2' = upper_closure_matchexpr a (MatchNot m2) in
      (if m1' = MatchAny  m2' = MatchAny
       then MatchAny
       else 
          if m1' = MatchNot MatchAny then m2' else
          if m2' = MatchNot MatchAny then m1'
       else
          MatchNot (MatchAnd (MatchNot m1') (MatchNot m2')))
         )" |
    "upper_closure_matchexpr _ (MatchNot m) = MatchNot m" | 
    "upper_closure_matchexpr a (MatchAnd m1 m2) = MatchAnd (upper_closure_matchexpr a m1) (upper_closure_matchexpr a m2)"
  
  lemma upper_closure_matchexpr_generic: 
    "a = Accept  a = Drop  remove_unknowns_generic (common_matcher, in_doubt_allow) a m = upper_closure_matchexpr a m"
    by(induction a m rule: upper_closure_matchexpr.induct)
      (simp_all add: remove_unknowns_generic_simps2 bool_to_ternary_Unknown common_matcher_SrcDst_defined)
  
  fun lower_closure_matchexpr :: "action  'i::len common_primitive match_expr  'i common_primitive match_expr" where
    "lower_closure_matchexpr _ MatchAny = MatchAny" |
    "lower_closure_matchexpr Accept (Match (Extra _)) = MatchNot MatchAny" |
    "lower_closure_matchexpr Reject (Match (Extra _)) = MatchAny" |
    "lower_closure_matchexpr Drop (Match (Extra _)) = MatchAny" |
    "lower_closure_matchexpr _ (Match m) = Match m" |
    "lower_closure_matchexpr Accept (MatchNot (Match (Extra _))) = MatchNot MatchAny" |
    "lower_closure_matchexpr Drop (MatchNot (Match (Extra _))) = MatchAny" |
    "lower_closure_matchexpr Reject (MatchNot (Match (Extra _))) = MatchAny" |
    "lower_closure_matchexpr a (MatchNot (MatchNot m)) = lower_closure_matchexpr a m" |
    "lower_closure_matchexpr a (MatchNot (MatchAnd m1 m2)) = 
      (let m1' = lower_closure_matchexpr a (MatchNot m1); m2' = lower_closure_matchexpr a (MatchNot m2) in
      (if m1' = MatchAny  m2' = MatchAny
       then MatchAny
       else 
          if m1' = MatchNot MatchAny then m2' else
          if m2' = MatchNot MatchAny then m1'
       else
          MatchNot (MatchAnd (MatchNot m1') (MatchNot m2')))
         )" |
    "lower_closure_matchexpr _ (MatchNot m) = MatchNot m" | 
    "lower_closure_matchexpr a (MatchAnd m1 m2) = MatchAnd (lower_closure_matchexpr a m1) (lower_closure_matchexpr a m2)"
  
  lemma lower_closure_matchexpr_generic: 
    "a = Accept  a = Drop  remove_unknowns_generic (common_matcher, in_doubt_deny) a m = lower_closure_matchexpr a m"
    by(induction a m rule: lower_closure_matchexpr.induct)
    (simp_all add: remove_unknowns_generic_simps2 bool_to_ternary_Unknown common_matcher_SrcDst_defined)



end

Theory Example_Semantics

theory Example_Semantics
imports Call_Return_Unfolding "Primitive_Matchers/Common_Primitive_Matcher"
begin


section‹Examples Big Step Semantics›
text‹We use a primitive matcher which always applies. We don't care about matching in this example.›
  fun applies_Yes :: "('a, 'p) matcher" where
  "applies_Yes m p = True" 
  lemma[simp]: "Semantics.matches applies_Yes MatchAny p" by simp
  lemma[simp]: "Semantics.matches applies_Yes (Match e) p" by simp

  definition "m=Match (Src (IpAddr (0::ipv4addr)))"
  lemma[simp]: "Semantics.matches applies_Yes m p" by (simp add: m_def)

  lemma "[''FORWARD''  [(Rule m Log), (Rule m Accept), (Rule m Drop)]],applies_Yes,p
      [Rule MatchAny (Call ''FORWARD'')], Undecided  (Decision FinalAllow)"
  apply(rule call_result)
    apply(auto)
  apply(rule seq_cons)
   apply(auto intro:Semantics.log)
  apply(rule seq_cons)
   apply(auto intro: Semantics.accept)
  apply(rule Semantics.decision)
  done
  
  lemma "[''FORWARD''  [(Rule m Log), (Rule m (Call ''foo'')), (Rule m Accept)],
          ''foo''  [(Rule m Log), (Rule m Return)]],applies_Yes,p
      [Rule MatchAny (Call ''FORWARD'')], Undecided  (Decision FinalAllow)"
  apply(rule call_result)
    apply(auto)
  apply(rule seq_cons)
   apply(auto intro: Semantics.log)
  apply(rule seq_cons)
   apply(rule Semantics.call_return[where rs1="[Rule m Log]" and rs2="[]"])
      apply(simp)+
   apply(auto intro: Semantics.log)
  apply(auto intro: Semantics.accept)
  done
  
  lemma "[''FORWARD''  [Rule m (Call ''foo''), Rule m Drop], ''foo''  []],applies_Yes,p
            [Rule MatchAny (Call ''FORWARD'')], Undecided  (Decision FinalDeny)"
  apply(rule call_result)
    apply(auto)
  apply(rule Semantics.seq_cons)
   apply(rule Semantics.call_result)
     apply(auto)
   apply(rule Semantics.skip)
  apply(auto intro: deny)
  done

  lemma "((λrs. process_call [''FORWARD''  [Rule m (Call ''foo''), Rule m Drop], ''foo''  []] rs)^^2)
                    [Rule MatchAny (Call ''FORWARD'')]
         = [Rule (MatchAnd MatchAny m) Drop]" by eval

  hide_const m
  
  definition "pkt=p_iiface=''+'', p_oiface=''+'', p_src=0, p_dst=0,
                   p_proto=TCP, p_sport=0, p_dport=0, p_tcp_flags = {TCP_SYN},
                   p_payload='''',p_tag_ctstate= CT_New"

  text‹We tune the primitive matcher to support everything we need in the example. Note that the undefined cases cannot be handled with these exact semantics!›
  fun applies_exampleMatchExact :: "(32 common_primitive, 32 tagged_packet) matcher" where
  "applies_exampleMatchExact (Src (IpAddr addr)) p  p_src p = addr" |
  "applies_exampleMatchExact (Dst (IpAddr addr)) p  p_dst p = addr" |
  "applies_exampleMatchExact (Prot ProtoAny) p  True" |
  "applies_exampleMatchExact (Prot (Proto pr)) p  p_proto p = pr"
  (* not exhaustive, only an example!!*)

  lemma "[''FORWARD''  [ Rule (MatchAnd (Match (Src (IpAddr 0))) (Match (Dst (IpAddr 0)))) Reject, 
                          Rule (Match (Dst (IpAddr 0))) Log, 
                          Rule (Match (Prot (Proto TCP))) Accept,
                          Rule (Match (Prot (Proto TCP))) Drop]
         ],applies_exampleMatchExact, pktp_src:=(ipv4addr_of_dotdecimal (1,2,3,4)), p_dst:=(ipv4addr_of_dotdecimal (0,0,0,0))
            [Rule MatchAny (Call ''FORWARD'')], Undecided  (Decision FinalAllow)"
  apply(rule call_result)
    apply(auto)
  apply(rule Semantics.seq_cons)
   apply(auto intro: Semantics.nomatch simp add: ipv4addr_of_dotdecimal.simps ipv4addr_of_nat_def)
  apply(rule Semantics.seq_cons)
   apply(auto intro: Semantics.log simp add: ipv4addr_of_dotdecimal.simps ipv4addr_of_nat_def)
  apply(rule Semantics.seq_cons)
   apply(auto simp add: pkt_def intro: Semantics.accept)
  apply(auto intro: Semantics.decision)
  done

end

Theory Alternative_Semantics

theory Alternative_Semantics
imports Semantics
begin
  
context begin
  
(* the first thing (I think) we have to do is alter the Seq rule / merge it with NoMatch.
 Its properties make it hard to work with… *)
private inductive iptables_bigstep_ns :: "'a ruleset  ('a, 'p) matcher  'p  'a rule list  state  state  bool"
  ("_,_,_ _, _ s _"  [60,60,60,20,98,98] 89)
  for Γ and γ and p where
skip:    "Γ,γ,p [], t s t" |
accept:  "matches γ m p  Γ,γ,p Rule m Accept # rs, Undecided s Decision FinalAllow" |
drop:    "matches γ m p  Γ,γ,p Rule m Drop # rs, Undecided s Decision FinalDeny" |
reject:  "matches γ m p   Γ,γ,p Rule m Reject # rs, Undecided s Decision FinalDeny" |
log:     "matches γ m p  Γ,γ,p rs, Undecided s t  Γ,γ,p Rule m Log # rs, Undecided s t" |
empty:   "matches γ m p  Γ,γ,p rs, Undecided s t  Γ,γ,p Rule m Empty # rs, Undecided s t" |
nms:     "¬ matches γ m p  Γ,γ,p rs, Undecided s t  Γ,γ,p Rule m a # rs, Undecided s t" |
(*decision: "Γ,γ,p⊢ ⟨rs, Decision X⟩ ⇒s Decision X" |*)
call_return:  " matches γ m p; Γ chain = Some (rs1 @ Rule m' Return # rs2);
                 matches γ m' p; Γ,γ,p rs1, Undecided s Undecided; Γ,γ,p rrs, Undecided s t  
               Γ,γ,p Rule m (Call chain) # rrs, Undecided s t" |
call_result:  " matches γ m p; Γ chain = Some rs; Γ,γ,p rs, Undecided s Decision X  
               Γ,γ,p Rule m (Call chain) # rrs, Undecided s Decision X" |
call_no_result:  " matches γ m p; Γ chain = Some rs; Γ,γ,p rs, Undecided s Undecided;
                    Γ,γ,p rrs, Undecided s t  
               Γ,γ,p Rule m (Call chain) # rrs, Undecided s t"

private lemma a: "Γ,γ,p rs, s s t  Γ,γ,p rs, s  t"
  apply(induction rule: iptables_bigstep_ns.induct; (simp add: iptables_bigstep.intros;fail)?)
  apply (meson iptables_bigstep.decision iptables_bigstep.accept seq_cons)
  apply (meson iptables_bigstep.decision iptables_bigstep.drop seq_cons)
  apply (meson iptables_bigstep.decision iptables_bigstep.reject seq_cons)
  apply (meson iptables_bigstep.log seq_cons)
  apply (meson iptables_bigstep.empty seq_cons)
  apply (meson nomatch seq_cons)
  subgoal using iptables_bigstep.call_return seq_cons by fastforce
  apply (meson iptables_bigstep.decision iptables_bigstep.call_result seq_cons)
  apply (meson iptables_bigstep.call_result seq'_cons)
  done

private lemma empty_rs_stateD: assumes "Γ,γ,p [], s s t" shows "t = s"
  using assms by(cases rule: iptables_bigstep_ns.cases)
private lemma decided: "Γ,γ,p rs1, Undecided s Decision X  Γ,γ,p rs1@rs2, Undecided s Decision X"
proof(induction rs1)
  case Nil
  then show ?case by (fast dest: empty_rs_stateD)
next
  case (Cons a rs1)
  from Cons.prems show ?case 
    by(cases rule: iptables_bigstep_ns.cases; simp add: Cons.IH iptables_bigstep_ns.intros)
qed
  
private lemma decided_determ: "Γ,γ,p rs1, s s t; s = Decision X  t = Decision X"
  by(induction rule: iptables_bigstep_ns.induct; (simp add: iptables_bigstep_ns.intros;fail)?)

private lemma seq_ns:
  "Γ,γ,p rs1, Undecided s t; Γ,γ,p rs2, t s t'  Γ,γ,p rs1@rs2, Undecided s t'"
proof (cases t, goal_cases)
  case 1
  from 1(1,2) show ?case unfolding 1 proof(induction rs1)
    case (Cons a rs3)
    then show ?case
      apply -
      apply(rule iptables_bigstep_ns.cases[OF Cons.prems(1)]; simp add: iptables_bigstep_ns.intros)
    done
  qed simp
next
  case (2 X)
  hence "t' = Decision X" by (simp add: decided_determ)
  from 2(1) show ?case by (simp add: "2"(3) t' = Decision X decided)
qed
      
private lemma b: "Γ,γ,p rs, s  t  s = Undecided  Γ,γ,p rs, s s t"
  apply(induction rule: iptables_bigstep.induct; (simp add: iptables_bigstep_ns.intros;fail)?)
   apply (metis decided decision seq_ns seq_progress skipD state.exhaust)
  apply(metis call_no_result iptables_bigstep_ns.call_result iptables_bigstep_ns.skip state.exhaust)
  done
    
private inductive iptables_bigstep_nz :: "'a ruleset  ('a, 'p) matcher  'p  'a rule list  state  bool"
  ("_,_,_ _ z _"  [60,60,60,20,98] 89)
  for Γ and γ and p where
skip:    "Γ,γ,p  []  z Undecided" |
accept:  "matches γ m p  Γ,γ,p Rule m Accept # rs z Decision FinalAllow" |
drop:    "matches γ m p  Γ,γ,p Rule m Drop # rs z Decision FinalDeny" |
reject:  "matches γ m p   Γ,γ,p Rule m Reject # rs z Decision FinalDeny" |
log:     "matches γ m p  Γ,γ,p rs z t  Γ,γ,p Rule m Log # rs z t" |
empty:   "matches γ m p  Γ,γ,p rs z t  Γ,γ,p Rule m Empty # rs z t" |
nms:     "¬ matches γ m p  Γ,γ,p rs z t  Γ,γ,p Rule m a # rs z t" |
call_return:  " matches γ m p; Γ chain = Some (rs1 @ Rule m' Return # rs2);
                 matches γ m' p; Γ,γ,p rs1 z Undecided; Γ,γ,p rrs z t  
               Γ,γ,p Rule m (Call chain) # rrs z t" |
call_result:  " matches γ m p; Γ chain = Some rs; Γ,γ,p rs z Decision X  
               Γ,γ,p Rule m (Call chain) # rrs z Decision X" |
call_no_result:  " matches γ m p; Γ chain = Some rs; Γ,γ,p rs z Undecided;
                    Γ,γ,p rrs z t  
               Γ,γ,p Rule m (Call chain) # rrs z t"

private lemma c: "Γ,γ,p rs z t  Γ,γ,p rs, Undecided s t"
  by(induction rule: iptables_bigstep_nz.induct; simp add: iptables_bigstep_ns.intros)
    
private lemma d: "Γ,γ,p rs, s s t  s = Undecided  Γ,γ,p rs z t"
  by(induction rule: iptables_bigstep_ns.induct; simp add: iptables_bigstep_nz.intros)
    
inductive iptables_bigstep_r :: "'a ruleset  ('a, 'p) matcher  'p  'a rule list  state  bool"
  ("_,_,_ _ r _"  [60,60,60,20,98] 89)
  for Γ and γ and p where
skip:    "Γ,γ,p  []  r Undecided" |
accept:  "matches γ m p  Γ,γ,p Rule m Accept # rs r Decision FinalAllow" |
drop:    "matches γ m p  Γ,γ,p Rule m Drop # rs r Decision FinalDeny" |
reject:  "matches γ m p   Γ,γ,p Rule m Reject # rs r Decision FinalDeny" |
return:  "matches γ m p   Γ,γ,p Rule m Return # rs r Undecided" |
log:     "Γ,γ,p rs r t  Γ,γ,p Rule m Log # rs r t" |
empty:   "Γ,γ,p rs r t  Γ,γ,p Rule m Empty # rs r t" |
nms:     "¬ matches γ m p  Γ,γ,p rs r t  Γ,γ,p Rule m a # rs r t" |
call_result:  " matches γ m p; Γ chain = Some rs; Γ,γ,p rs r Decision X  
               Γ,γ,p Rule m (Call chain) # rrs r Decision X" |
call_no_result:  " Γ chain = Some rs; Γ,γ,p rs r Undecided;
                    Γ,γ,p rrs r t  
               Γ,γ,p Rule m (Call chain) # rrs r t"

private lemma returning:  "Γ,γ,p rs1 r Undecided; matches γ m' p
     Γ,γ,p rs1 @ Rule m' Return # rs2 r Undecided"
proof(induction rs1)
  case Nil
  then show ?case by (simp add: return)
next
  case (Cons a rs3)
  then show ?case by - (rule iptables_bigstep_r.cases[OF Cons.prems(1)]; simp add: iptables_bigstep_r.intros)
qed
 
private lemma e: "Γ,γ,p rs z t  s = Undecided  Γ,γ,p rs r t"
  by(induction rule: iptables_bigstep_nz.induct; simp add: iptables_bigstep_r.intros returning)
    

definition "no_call_to c rs  (r  set rs. case get_action r of Call c'  c  c' | _  True)"
definition "all_chains p Γ rs  (p rs  (l rs. Γ l = Some rs  p rs))"
private lemma all_chains_no_call_upd: "all_chains (no_call_to c) Γ rs  (Γ(c  x)),γ,p rs z t  Γ,γ,p rs z t"
proof (rule iffI, goal_cases)
  case 1
  from 1(2,1) show ?case 
    by(induction rule: iptables_bigstep_nz.induct; 
      (simp add: iptables_bigstep_nz.intros no_call_to_def all_chains_def split: if_splits;fail)?)
next
  case 2
  from 2(2,1) show ?case 
    by(induction rule: iptables_bigstep_nz.induct; 
      (simp add: iptables_bigstep_nz.intros no_call_to_def all_chains_def split:  action.splits;fail)?)
qed

lemma updated_call: "Γ(c  rs),γ,p rs z t  matches γ m p  Γ(c  rs),γ,p [Rule m (Call c)] z t"
  by(cases t; simp add: iptables_bigstep_nz.call_no_result iptables_bigstep_nz.call_result iptables_bigstep_nz.skip)
    
private lemma shows
      log_nz:     "Γ,γ,p rs z t  Γ,γ,p Rule m Log # rs z t"
and empty_nz:   "Γ,γ,p rs z t  Γ,γ,p Rule m Empty # rs z t"
  by (meson iptables_bigstep_nz.log iptables_bigstep_nz.empty iptables_bigstep_nz.nms)+
    
private lemma nz_empty_rs_stateD: assumes "Γ,γ,p [] z t" shows "t = Undecided"
  using assms by(cases rule: iptables_bigstep_nz.cases)
    
private lemma upd_callD: "Γ(c  rs),γ,p [Rule m (Call c)] z t  matches γ m p 
   (Γ(c  rs),γ,p rs z t  (rs1 rs2 m'. rs = rs1 @ Rule m' Return # rs2  matches γ m' p  Γ(c  rs),γ,p rs1 z Undecided  t = Undecided))"
  by(subst (asm) iptables_bigstep_nz.simps) (auto dest!: nz_empty_rs_stateD)
    
private lemma partial_fun_upd: "(f(x  y)) x = Some y" by(fact fun_upd_same)
 
lemma f: "Γ,γ,p rs r t  matches γ m p  all_chains (no_call_to c) Γ rs  
  (Γ(c  rs)),γ,p [Rule m (Call c)] z t"
proof(induction rule: iptables_bigstep_r.induct; (simp add: iptables_bigstep_nz.intros;fail)?)
  case (return m rs)
  then show ?case by (metis append_Nil fun_upd_same iptables_bigstep_nz.call_return iptables_bigstep_nz.skip)
next
  case (log rs t mx)
  have ac: "all_chains (no_call_to c) Γ rs"
    using log(4) by(simp add: all_chains_def no_call_to_def)
  have *: "Γ(c  Rule mx Log # rs1 @ Rule m' Return # rs2),γ,p [Rule m (Call c)] z Undecided"
    if "rs = rs1 @ Rule m' Return # rs2" "matches γ m' p" 
       "Γ(c  rs1 @ Rule m' Return # rs2),γ,p rs1 z Undecided"
    for rs1 rs2 m'
  proof -
    have ac2: "all_chains (no_call_to c) Γ rs1" using log(4) that
      by(simp add: all_chains_def no_call_to_def)
    hence "Γ(c  Rule mx Log # rs1 @ Rule m' Return # rs2),γ,p rs1 z Undecided"
      using that(3) unfolding that by(simp add: all_chains_no_call_upd)
        hence "Γ(c  Rule mx Log # rs1 @ Rule m' Return # rs2),γ,p Rule mx Log # rs1 z Undecided"
      by (simp add: log_nz)
    thus ?thesis using that(1,2)
      by(elim iptables_bigstep_nz.call_return[where rs2=rs2, OF ‹matches γ m p, rotated]; simp add: iptables_bigstep_nz.skip)
  qed
  from log(2)[OF log(3) ac] show ?case
    apply -
    apply(drule upd_callD[OF _ ‹matches γ m p])
    apply(erule disjE)
    subgoal
      apply(rule updated_call[OF _ ‹matches γ m p])
      apply(rule log_nz)
      apply(simp add: ac all_chains_no_call_upd)
      done
    using * by blast
next
  case (empty rs t mx) text‹analogous› (*<*)
  have ac: "all_chains (no_call_to c) Γ rs"
    using empty(4) by(simp add: all_chains_def no_call_to_def)
  have *: "Γ(c  Rule mx Empty # rs1 @ Rule m' Return # rs2),γ,p [Rule m (Call c)] z Undecided"
    if "rs = rs1 @ Rule m' Return # rs2" "matches γ m' p" 
       "Γ(c  rs1 @ Rule m' Return # rs2),γ,p rs1 z Undecided"
    for rs1 rs2 m'
  proof -
    have ac2: "all_chains (no_call_to c) Γ rs1" using empty(4) that
      by(simp add: all_chains_def no_call_to_def)
    hence "Γ(c  Rule mx Empty # rs1 @ Rule m' Return # rs2),γ,p rs1 z Undecided"
      using that(3) unfolding that by(simp add: all_chains_no_call_upd)
        hence "Γ(c  Rule mx Empty # rs1 @ Rule m' Return # rs2),γ,p Rule mx Empty # rs1 z Undecided"
      by (simp add: empty_nz)
    thus ?thesis using that(1,2)
      by(elim iptables_bigstep_nz.call_return[where rs2=rs2, OF ‹matches γ m p, rotated]; simp add: iptables_bigstep_nz.skip)
  qed
  from empty(2)[OF empty(3) ac] show ?case
    apply -
    apply(drule upd_callD[OF _ ‹matches γ m p])
    apply(erule disjE)
    subgoal
      apply(rule updated_call[OF _ ‹matches γ m p])
      apply(rule empty_nz)
      apply(simp add: ac all_chains_no_call_upd)
      done
    using * by blast
    (*>*)
next
  case (nms m' rs t a)
  have ac: "all_chains (no_call_to c) Γ rs" using nms(5) by(simp add: all_chains_def no_call_to_def)
  from nms.IH[OF nms(4) ac] show ?case
    apply -
    apply(drule upd_callD[OF _ ‹matches γ m p])
    apply(erule disjE)
    subgoal
      apply(rule updated_call[OF _ ‹matches γ m p])
      apply(rule iptables_bigstep_nz.nms[OF ¬ matches γ m' p])
      apply(simp add: ac all_chains_no_call_upd)
      done
    apply safe
    subgoal for rs1 rs2 r
      apply(subgoal_tac "all_chains (no_call_to c) Γ rs1") (* Ich kann auch anders. *)
       apply(subst (asm) all_chains_no_call_upd, assumption)
       apply(subst (asm) all_chains_no_call_upd[symmetric], assumption)
       apply(drule iptables_bigstep_nz.nms[where a=a, OF ¬ matches γ m' p])
       apply(erule (1) iptables_bigstep_nz.call_return[where rs2=rs2, OF ‹matches γ m p, rotated])
        apply(insert ac; simp add: all_chains_def no_call_to_def iptables_bigstep_nz.skip)+
      done
    done
next
  case (call_result m' c' rs X rrs)
  have acrs: "all_chains (no_call_to c) Γ rs" using call_result(2,6) by(simp add: all_chains_def no_call_to_def)
  have cc: "c  c'" (* okay, this one is a bit nifty… *) using call_result(6) by(simp add: all_chains_def no_call_to_def)
  have "Γ(c  rs),γ,p [Rule m (Call c)] z Decision X" using call_result.IH call_result.prems(1) acrs by blast
  then show ?case
    apply -
    apply(drule upd_callD[OF _ ‹matches γ m p])
    apply(erule disjE)
    subgoal
      apply(rule updated_call[OF _ ‹matches γ m p])
      apply(rule iptables_bigstep_nz.call_result[where rs=rs, OF ‹matches γ m' p ])
      apply(simp add: cc[symmetric] call_result(2);fail)
      apply(simp add: acrs all_chains_no_call_upd;fail)
      done
    apply safe (* oh. Didn't expect that. :) *)
  done
next
  case (call_no_result c' rs rrs t m')
  have acrs: "all_chains (no_call_to c) Γ rs" using call_no_result(1,7) by(simp add: all_chains_def no_call_to_def)
  have acrrs: "all_chains (no_call_to c) Γ rrs" using call_no_result(7) by(simp add: all_chains_def no_call_to_def)
  have acrs1: "all_chains (no_call_to c) Γ rs1" if "rs = rs1 @ rs2" for rs1 rs2
    using acrs that by(simp add: all_chains_def no_call_to_def)
  have acrrs1: "all_chains (no_call_to c) Γ rs1" if "rrs = rs1 @ rs2" for rs1 rs2
    using acrrs that by(simp add: all_chains_def no_call_to_def)
  have cc: "c  c'" (* okay, this one is a bit nifty… *) using call_no_result(7) by(simp add: all_chains_def no_call_to_def)
  have *: "Γ(c  rs),γ,p [Rule m (Call c)] z Undecided" using call_no_result.IH call_no_result.prems(1) acrs by blast
  have **: "Γ(c  rrs),γ,p [Rule m (Call c)] z t" by (simp add: acrrs call_no_result.IH(2) call_no_result.prems(1))
  show ?case proof(cases ‹matches γ m' p)
    case True
    from call_no_result(5)[OF ‹matches γ m p acrrs] * show ?thesis
      apply -
      apply(drule upd_callD[OF _ ‹matches γ m p])+
      apply(elim disjE) (* 4 sg *)
      apply safe
      subgoal
        apply(rule updated_call[OF _ ‹matches γ m p])
        apply(rule iptables_bigstep_nz.call_no_result[where rs=rs, OF ‹matches γ m' p ])
        apply(simp add: cc[symmetric] call_no_result(1);fail)
         apply(simp add: acrs all_chains_no_call_upd;fail)
        apply(simp add: acrrs all_chains_no_call_upd)
        done
      subgoal for rs1 rs2 r
        apply(rule updated_call[OF _ ‹matches γ m p])
        apply(rule call_return[OF ‹matches γ m' p])
           apply(simp add: cc[symmetric] call_no_result(1);fail)
          apply(simp;fail)
         apply(simp add: acrs1 all_chains_no_call_upd;fail)
        apply(simp add: acrrs all_chains_no_call_upd)
        done
      subgoal for rs1 rs2 r
        apply(rule call_return[where rs1="Rule m' (Call c') # rs1", OF ‹matches γ m p])
           apply(simp;fail)
          apply(simp;fail)
        apply(rule iptables_bigstep_nz.call_no_result[OF ‹matches γ m' p])
           apply(simp add: cc[symmetric] call_no_result(1);fail)
          apply (meson acrs all_chains_no_call_upd)
         apply(subst all_chains_no_call_upd; simp add: acrrs1 all_chains_no_call_upd; fail)
        apply (simp add: iptables_bigstep_nz.skip;fail)
        done
      subgoal for rrs1 rs1 rrs2 rs2 rr r
         apply(rule call_return[where rs1="Rule m' (Call c') # rrs1", OF ‹matches γ m p])
           apply(simp;fail)
          apply(simp;fail)
         apply(rule call_return[OF ‹matches γ m' p])
            apply(simp add: cc[symmetric] call_no_result(1);fail)
           apply blast
          apply (meson acrs1 all_chains_no_call_upd)
         apply(subst all_chains_no_call_upd; simp add: acrrs1 all_chains_no_call_upd; fail)
        apply (simp add: iptables_bigstep_nz.skip;fail)
        done
      done
  next
    case False
    from iptables_bigstep_nz.nms[OF False] ** show ?thesis 
      apply -
      apply(drule upd_callD[OF _ ‹matches γ m p])+
      apply(elim disjE)
      subgoal
        apply(rule updated_call[OF _ ‹matches γ m p])
        apply(rule iptables_bigstep_nz.nms[OF False])
        apply(simp add: acrrs all_chains_no_call_upd)
        done
      apply safe
      subgoal for rs1 rs2 r
        apply(rule call_return[where rs1="Rule m' (Call c') # rs1", OF ‹matches γ m p])
           apply(simp;fail)
          apply(simp;fail)
         apply(rule iptables_bigstep_nz.nms[OF False])
         apply(subst all_chains_no_call_upd; simp add: acrrs1 all_chains_no_call_upd; fail)
        apply(simp add: iptables_bigstep_nz.skip;fail)
        done
      done
  qed
qed
  
lemma r_skip_inv: "Γ,γ,p [] r t  t = Undecided"
  by(subst (asm) iptables_bigstep_r.simps) auto
  
(* why did I do all this? essentially, because I thought this should be derivable: *)
lemma r_call_eq: "Γ c = Some rs  matches γ m p  Γ,γ,p [Rule m (Call c)] r t  Γ,γ,p rs r t"
(* and yes, there is a more general form of this lemma, but… meh. *)
  apply(rule iffI)
  subgoal
    apply(subst (asm) iptables_bigstep_r.simps)
    apply(auto dest: r_skip_inv)
  done
  subgoal
    apply(cases t)
     apply(erule iptables_bigstep_r.call_no_result)
      apply(simp;fail)
     apply(simp add: iptables_bigstep_r.skip;fail)
      apply(simp)
    apply(erule (2) iptables_bigstep_r.call_result)
  done
  by -

(* we can make the same formulation for the original semantics if we tread a bit more carefully *)
lemma call_eq: "Γ c = Some rs  matches γ m p  r  set rs. get_action r  Return   Γ,γ,p [Rule m (Call c)],s  t  Γ,γ,p rs,s  t"
  apply(rule iffI)
  subgoal
    apply(subst (asm) iptables_bigstep.simps)
    apply (auto)
     apply (simp add: decision)
    apply(erule rules_singleton_rev_E; simp; metis callD in_set_conv_decomp rule.sel(2) skipD)
  done
  by (metis decision iptables_bigstep.call_result iptables_bigstep_deterministic state.exhaust)
  
theorem r_eq_orig: "all_chains (no_call_to c) Γ rs; Γ c = Some rs 
   Γ,γ,p rs r t  Γ,γ,p [Rule MatchAny (Call c)], Undecided  t"
  apply(rule iffI)
  subgoal
    apply(drule f[where m=MatchAny, THEN c, THEN a])
      apply(simp;fail)
     apply(simp;fail)
    apply (metis fun_upd_triv)
    done  
  subgoal
    apply(subst r_call_eq[where m=MatchAny, symmetric])
      apply(simp;fail)
     apply(simp;fail)
    apply(erule b[THEN d, THEN e, OF _ refl refl refl])
    done
  done
    
lemma r_no_call: "Γ,γ,p Rule MatchAny (Call c)#rs r t  Γ c = None  False"
  by(subst (asm) iptables_bigstep_r.simps) simp
    
lemma no_call: "Γ,γ,p rs, s  t  rs = [Rule MatchAny (Call c)]  s = Undecided  Γ c = None  False"
  by (meson b d e r_no_call)
  (*by(induction rule: iptables_bigstep.induct; clarsimp) (metis list_app_singletonE skipD)*)

private corollary r_eq_orig': assumes "rs  ran Γ. no_call_to c rs"
  shows "Γ,γ,p [Rule MatchAny (Call c)] r t  Γ,γ,p [Rule MatchAny (Call c)], Undecided  t"
(* if you really like symmetry *)
proof -
  show ?thesis proof (cases "Γ c")
    fix rs
    assume "Γ c = Some rs"
    moreover hence "all_chains (no_call_to c) Γ rs" using assms by (simp add: all_chains_def ranI)
    ultimately show ?thesis by(simp add: r_call_eq r_eq_orig)
  next
    assume "Γ c = None" thus ?thesis using r_no_call no_call by metis
  qed
qed
  
(* btw, we can still formulate a seq rules, but we have to tread a bit more carefully *)
lemma r_tail: assumes "Γ,γ,p rs1 r Decision X" shows "Γ,γ,p rs1 @ rs2 r Decision X"
proof -
  have "Γ,γ,p rs1 r t  t = Decision X  Γ,γ,p rs1 @ rs2 r Decision X" for t
    by(induction rule: iptables_bigstep_r.induct; simp add: iptables_bigstep_r.intros)
  thus ?thesis using assms by blast
qed
lemma r_seq: "Γ,γ,p rs1 r Undecided  r  set rs1. ¬(get_action r = Return  matches γ (get_match r) p)
    Γ,γ,p rs2 r t  Γ,γ,p rs1 @ rs2 r t"
proof(induction rs1)
  case Nil
  then show ?case by simp
next
  case (Cons r rs1)
  have p2: "rset rs1. ¬ (get_action r = Return  matches γ (get_match r) p)" 
           "¬(get_action r = Return  matches γ (get_match r) p)"
    by (simp_all add: Cons.prems(2))
  from Cons.prems(1) p2(2) Cons.IH[OF _ p2(1) Cons.prems(3)] show ?case 
    by(cases rule: iptables_bigstep_r.cases; simp add: iptables_bigstep_r.intros)
qed

lemma r_appendD: "Γ,γ,p rs1 @ rs2 r t  s. Γ,γ,p rs1 r s"
  proof(induction rs1)
    case (Cons r rs1)
    from Cons.prems Cons.IH show ?case by(cases rule: iptables_bigstep_r.cases) (auto intro: iptables_bigstep_r.intros)
  qed (meson iptables_bigstep_r.skip)

corollary iptables_bigstep_r_eq: assumes "rs  ran Γ. no_call_to c rs" "A = Accept  A = Drop"
  shows "Γ,γ,p [Rule MatchAny (Call c), Rule MatchAny A] r t  Γ,γ,p [Rule MatchAny (Call c), Rule MatchAny A], Undecided  t"
(* if you really like the way we do our analyses *)
proof -
  show ?thesis proof (cases "Γ c")
    fix rs
    assume "Γ c = Some rs"
    moreover hence "all_chains (no_call_to c) Γ rs" using assms by (simp add: all_chains_def ranI)
    show ?thesis
      (* if this proof breaks, don't fix it. say 'meh' and re-prove this as a corollary of r_eq_orig''' with a stronger assumption *)
      apply(rule iffI[rotated])
       apply(erule seqE_cons)
       apply(subst (asm) r_eq_orig'[symmetric])
        apply (simp add: assms(1);fail)
       apply (meson assms(1) b d e r_eq_orig' seq'_cons) (* holy shi… *)
      apply(frule r_appendD[of _ _ _ "[Rule MatchAny (Call c)]" "[Rule MatchAny A]", simplified])
      apply(subst (asm) r_eq_orig')
        apply (simp add: assms(1);fail)
        apply(clarsimp)
      apply(subst (asm) r_eq_orig'[symmetric])
       apply (simp add: assms(1);fail)
      apply(subst (asm)(2) iptables_bigstep_r.simps)
      apply(subst (asm)(1) iptables_bigstep_r.simps)
      apply auto
         apply (metis append_Cons append_Nil assms(1) decision matches.simps(4) r_call_eq r_eq_orig' seq)
        apply (metis ‹all_chains (no_call_to c) Γ rs calculation iptables_bigstep_deterministic option.inject r_eq_orig state.distinct(1))
      subgoal using ‹all_chains (no_call_to c) Γ rs calculation iptables_bigstep_deterministic r_eq_orig by fastforce
      apply(subst (asm) r_eq_orig[rotated])
        apply(assumption)
      subgoal using ‹all_chains (no_call_to c) Γ rs calculation by simp
      apply(erule seq'_cons)
      apply(subst (asm)(1) iptables_bigstep_r.simps)  
      apply(insert assms(2); auto simp add: iptables_bigstep.intros)
      done        
  next
    assume "Γ c = None" thus ?thesis using r_no_call no_call by (metis seqE_cons)
  qed
qed

(* now, you don't like that no_call_to assumption? this one's for you: *)
lemma ex_no_call: "finite S  c. (rs :: 'a rule list)  S. no_call_to c rs"
(* If you want, you can put in ‹ran Γ› for S. *)
proof -
  assume fS: ‹finite S
  define called_c where "called_c rs = {c. m. Rule m (Call c)  set rs}" for rs :: "'a rule list"
  define called_c' where "called_c' rs = set [c. r  rs, c  (case get_action r of Call c  [c] | _  [])]"
    for rs :: "'a rule list"
  have cc: "called_c' rs = called_c rs" for rs
    unfolding called_c'_def called_c_def
    by(induction rs; simp add: Un_def) (auto; metis rule.collapse)      
  have f: "finite (called_c rs)" for rs unfolding cc[symmetric] called_c'_def by blast
  have ncc: "no_call_to c rs  c  called_c rs" for c rs 
    by(induction rs; auto simp add: no_call_to_def called_c_def split: action.splits) (metis rule.collapse)
  have isu: "infinite (UNIV :: string set)" by (simp add: infinite_UNIV_listI)
  have ff: "finite (rs  S. called_c rs)" using f fS by simp
  then obtain c where ne: "c  (rs  S. called_c rs)"
    by (blast dest: ex_new_if_finite[OF isu])
  thus ?thesis by(intro exI[where x=c]) (simp add: ncc)
  (* stupid way of proving something, once again… *)
qed

private lemma ex_no_call': "finite (dom Γ)  c. Γ c = None  ((rs :: 'a rule list)  (ran Γ). no_call_to c rs)"
(* I want a corollary, and I need something a tad stronger… *)
proof -
  have *: "finite S  (dom M) = S  m. M = map_of m" for M S
  proof(induction arbitrary: M rule: finite.induct)
    case emptyI
    then show ?case by(intro exI[where x=Nil]) simp
  next
    case (insertI A a)
    show ?case proof(cases "a  A") (* stupid induction rule *)
      case True
      then show ?thesis using insertI by (simp add: insert_absorb)
    next
      case False
      hence "dom (M(a := None)) = A" using insertI.prems by simp
      from insertI.IH[OF this] obtain m where "M(a := None) = map_of m" ..
      then show ?thesis 
        by(intro exI[where x="(a, the (M a)) # m"]) (simp; metis domIff fun_upd_apply insertCI insertI.prems option.collapse)
    qed
  qed (* hm, thought that would give me what I want… *)
  have ran_alt: "ran f = (the o f) ` dom f" for f by(auto simp add: ran_def dom_def image_def)
  assume fD: ‹finite (dom Γ)
  hence fS: ‹finite (ran Γ) by(simp add: ran_alt)
  define called_c where "called_c rs = {c. m. Rule m (Call c)  set rs}" for rs :: "'a rule list"
  define called_c' where "called_c' rs = set [c. r  rs, c  (case get_action r of Call c  [c] | _  [])]"
    for rs :: "'a rule list"
  have cc: "called_c' rs = called_c rs" for rs
    unfolding called_c'_def called_c_def
    by(induction rs; simp add: Un_def) (auto; metis rule.collapse)      
  have f: "finite (called_c rs)" for rs unfolding cc[symmetric] called_c'_def by blast
  have ncc: "no_call_to c rs  c  called_c rs" for c rs 
    by(induction rs; auto simp add: no_call_to_def called_c_def split: action.splits) (metis rule.collapse) 
  have isu: "infinite (UNIV :: string set)" by (simp add: infinite_UNIV_listI)
  have ff: "finite (rs  ran Γ. called_c rs)" using f fS by simp
  hence fff: "finite (dom Γ  (rs  ran Γ. called_c rs))" using fD by simp
  then obtain c where ne: "c  (dom Γ  (rs  ran Γ. called_c rs))" thm ex_new_if_finite
    by (metis UNIV_I isu set_eqI)
  thus ?thesis by(fastforce simp add: ncc)
qed
  
lemma all_chains_no_call_upd_r: "all_chains (no_call_to c) Γ rs  (Γ(c  x)),γ,p rs r t  Γ,γ,p rs r t"
proof (rule iffI, goal_cases)
  case 1
  from 1(2,1) show ?case 
    by(induction rule: iptables_bigstep_r.induct; 
      (simp add: iptables_bigstep_r.intros no_call_to_def all_chains_def split: if_splits;fail)?)
next
  case 2
  from 2(2,1) show ?case 
    by(induction rule: iptables_bigstep_r.induct; 
      (simp add: iptables_bigstep_r.intros no_call_to_def all_chains_def split:  action.splits;fail)?)
qed

(* in a sense, this is code duplication with Ruleset_Update, but it's different enough that I can't use it. *)
lemma all_chains_no_call_upd_orig: "all_chains (no_call_to c) Γ rs  (Γ(c  x)),γ,p rs,s  t  Γ,γ,p rs,s  t"
proof (rule iffI, goal_cases)
  case 1
  from 1(2,1) show ?case 
    by(induction rs s t rule: iptables_bigstep.induct; 
      (simp add: iptables_bigstep.intros no_call_to_def all_chains_def split: if_splits;fail)?)
next
  case 2
  from 2(2,1) show ?case 
    by(induction rule: iptables_bigstep.induct; 
      (simp add: iptables_bigstep.intros no_call_to_def all_chains_def split:  action.splits;fail)?)
qed
  
  
corollary r_eq_orig''': assumes "finite (ran Γ)" and "r  set rs. get_action r  Return"
  shows "Γ,γ,p rs r t  Γ,γ,p rs, Undecided  t"
proof -
  from assms have "finite ({rs}  (ran Γ))" by simp
  from ex_no_call[OF this] obtain c where c: "(rsran Γ. no_call_to c rs)" "no_call_to c rs" by blast
  hence acnc: "all_chains (no_call_to c) Γ rs" unfolding all_chains_def by (simp add: ranI)
  have ranaway: "rsran (Γ(c  rs)). no_call_to c rs"
  proof -
    { (* hammer *)
      fix rsa :: "'a rule list"
      assume a1: "rsa  ran (Γ(c  rs))"
      have "R. rs  R  Collect (no_call_to c)"
        using c(2) by force
      then have "rsa  ran (Γ(c := None))  Collect (no_call_to c)"
        using a1 by (metis (no_types) Un_iff Un_insert_left fun_upd_same fun_upd_upd insert_absorb ran_map_upd)
      then have "no_call_to c rsa"
        by (metis (no_types) Un_iff c(1) mem_Collect_eq ranI ran_restrictD restrict_complement_singleton_eq)
    }
    thus ?thesis by simp
  qed
  have "Γ(c  rs),γ,p rs r t  Γ(c  rs),γ,p rs, Undecided  t"
    apply(subst r_call_eq[where c=c and m=MatchAny,symmetric])
      apply(simp;fail)
     apply(simp;fail)
    apply(subst call_eq[where c=c and m=MatchAny,symmetric])
      apply(simp;fail)
      apply(simp;fail)
     apply(simp add: assms;fail)
    apply(rule r_eq_orig')
    apply(fact ranaway)
    done
  thus ?thesis 
    apply -
    apply(subst (asm) all_chains_no_call_upd_r[where x=rs, OF acnc])
    apply(subst (asm) all_chains_no_call_upd_orig[where x=rs, OF acnc])
    .
qed

end

end

Theory Semantics_Stateful

theory Semantics_Stateful
imports Semantics
begin

section‹Semantics Stateful›

subsection‹Model 1 -- Curried Stateful Matcher›

text‹Processing a packet with state can be modeled as follows:
  The state is @{term σ}.
  The primitive matcher @{term γσ} is a curried function where the first argument is the state and
  it returns a stateless primitive matcher, i.e. @{term "γ = (γσ σ)"}.
  With this stateless primitive matcher @{term γ}, the @{const iptables_bigstep} semantics are executed.
  As entry point, the iptables built-in chains @{term "''INPUT''"}, @{term "''OUTPUT''"}, and @{term "''FORWARD''"} with their
  default-policy (@{const Accept} or @{const Drop} are valid for iptables) are chosen.
  The semantics must yield a @{term "Decision X"}.
  Due to the default-policy, this is always the case if the ruleset is well-formed.
  When a decision is made, the state @{term σ} is updated.›

inductive semantics_stateful ::
  "'a ruleset 
   (  ('a, 'p) matcher)  ― ‹matcher, first parameter is the state›
   (  final_decision  'p  )  ― ‹state update function after firewall has decision for a packet›
     ― ‹Starting state. constant›
   (string × action)  ― ‹The chain and default policy the firewall evaluates. For example ''FORWARD'', Drop›
   'p list  ― ‹packets to be processed›
   ('p × final_decision) list  ― ‹packets which have been processed and their decision. ordered the same as the firewall processed them. oldest packet first›
     ― ‹final state›
   bool" for Γ and γσ and state_update and σ0 where
  ― ‹A list of packets @{term ps} waiting to be processed. Nothing has happened, start and final state are the same, the list of processed packets is empty.›
  "semantics_stateful Γ γσ state_update σ0 (built_in_chain, default_policy) ps [] σ0" |

  ― ‹Processing one packet›
  "semantics_stateful Γ γσ state_update σ0 (built_in_chain, default_policy) (p#ps) ps_processed σ' 
   Γ,(γσ σ'),p [Rule MatchAny (Call built_in_chain), Rule MatchAny default_policy],Undecided  Decision X 
    semantics_stateful Γ γσ state_update σ0 (built_in_chain, default_policy) ps (ps_processed@[(p, X)]) (state_update σ' X p)"


lemma semantics_stateful_intro_process_one: "semantics_stateful Γ γσ state_upate σ0 (built_in_chain, default_policy) (p#ps) ps_processed_old σ_old 
       Γ,γσ σ_old,p [Rule MatchAny (Call built_in_chain), Rule MatchAny default_policy], Undecided  Decision X 
       σ' = state_upate σ_old X p 
       ps_processed = ps_processed_old@[(p, X)] 
       semantics_stateful Γ γσ state_upate σ0 (built_in_chain, default_policy) ps ps_processed σ'"
  by(auto intro: semantics_stateful.intros)

lemma semantics_stateful_intro_start: "σ0 = σ'  ps_processed = [] 
       semantics_stateful Γ γσ state_upate σ0 (built_in_chain, default_policy) ps ps_processed σ'"
  by(auto intro: semantics_stateful.intros)


text‹Example below›

subsection‹Model 2 -- Packets Tagged with State Information›

text‹In this model, the matcher is completely stateless but packets are previously tagged with
      (static) stateful information.›

inductive semantics_stateful_packet_tagging ::
   "'a ruleset 
    ('a, 'ptagged) matcher 
    (  'p  'ptagged)  ― ‹taggs the packet accordig to the current state before processing by firewall›
    (  final_decision  'p  )  ― ‹state updater›
      ― ‹Starting state. constant›
    (string × action) 
    'p list  ― ‹packets to be processed›
    ('p × final_decision) list  ― ‹packets which have been processed›
      ― ‹final state›
    bool" for Γ and γ and packet_tagger and state_update and σ0 where
  "semantics_stateful_packet_tagging Γ γ packet_tagger state_update σ0 (built_in_chain, default_policy) ps [] σ0" |

  "semantics_stateful_packet_tagging Γ γ packet_tagger state_update σ0 (built_in_chain, default_policy) (p#ps) ps_processed σ' 
   Γ,γ,(packet_tagger σ' p) [Rule MatchAny (Call built_in_chain), Rule MatchAny default_policy],Undecided  Decision X 
    semantics_stateful_packet_tagging Γ γ packet_tagger state_update σ0 (built_in_chain, default_policy) ps (ps_processed@[(p, X)]) (state_update σ' X p)"


lemma semantics_stateful_packet_tagging_intro_start: "σ0 = σ'  ps_processed = [] 
       semantics_stateful_packet_tagging Γ γ packet_tagger state_upate σ0 (built_in_chain, default_policy) ps ps_processed σ'"
  by(auto intro: semantics_stateful_packet_tagging.intros)

lemma semantics_stateful_packet_tagging_intro_process_one:
      "semantics_stateful_packet_tagging Γ γ packet_tagger state_upate σ0 (built_in_chain, default_policy) (p#ps) ps_processed_old σ_old 
       Γ,γ,(packet_tagger σ_old p) [Rule MatchAny (Call built_in_chain), Rule MatchAny default_policy], Undecided  Decision X 
       σ' = state_upate σ_old X p 
       ps_processed = ps_processed_old@[(p, X)] 
       semantics_stateful_packet_tagging Γ γ packet_tagger state_upate σ0 (built_in_chain, default_policy) ps ps_processed σ'"
  by(auto intro: semantics_stateful_packet_tagging.intros)


lemma semantics_bigstep_state_vs_tagged: 
  assumes "m::'m. stateful_matcher' σ m p = stateful_matcher_tagged' m (packet_tagger' σ p)" 
  shows "Γ,stateful_matcher' σ,p rs, Undecided  t 
         Γ,stateful_matcher_tagged',packet_tagger' σ p rs, Undecided  t"
proof -
  { fix m::"'m match_expr"
   from assms have
    "matches (stateful_matcher' σ) m p  matches stateful_matcher_tagged' m (packet_tagger' σ p)"
      by(induction m) (simp_all)
  } note matches_stateful_matcher_stateful_matcher_tagged=this

  show ?thesis (is "?lhs  ?rhs")
  proof
    assume ?lhs
    thus ?rhs
     proof(induction rs Undecided t rule: iptables_bigstep_induct)
     case (Seq _ _ _ t)
       thus ?case
         apply(cases t)
          apply (simp add: seq)
         apply(auto simp add: decision seq dest: decisionD)
         done
     qed(auto intro: iptables_bigstep.intros simp add: matches_stateful_matcher_stateful_matcher_tagged)
  next
    assume ?rhs
    thus ?lhs
     proof(induction rs Undecided t rule: iptables_bigstep_induct)
     case (Seq _ _ _ t)
       thus ?case
         apply(cases t)
          apply (simp add: seq)
         apply(auto  simp add: decision seq dest: decisionD)
         done
     qed(auto intro: iptables_bigstep.intros simp add: matches_stateful_matcher_stateful_matcher_tagged)
  qed
qed
   


text‹Both semantics are equal›
theorem semantics_stateful_vs_tagged:
  assumes "m σ p. stateful_matcher' σ m p = stateful_matcher_tagged' m (packet_tagger' σ p)" 
  shows "semantics_stateful rs stateful_matcher' state_update' σ0 start ps ps_processed σ' =
       semantics_stateful_packet_tagging rs stateful_matcher_tagged' packet_tagger' state_update' σ0 start ps ps_processed σ'"
  proof -
   from semantics_bigstep_state_vs_tagged[of stateful_matcher' _ _ stateful_matcher_tagged' packet_tagger'] assms
     have vs_tagged:
     "rs,stateful_matcher' σ',p [Rule MatchAny (Call built_in_chain), Rule MatchAny default_policy], Undecided  t 
      rs,stateful_matcher_tagged',packet_tagger' σ' p [Rule MatchAny (Call built_in_chain), Rule MatchAny default_policy], Undecided  t"
      for t p σ' built_in_chain default_policy by blast
   from assms have stateful_matcher_eq:
    "(λa b. stateful_matcher_tagged' a (packet_tagger' σ' b)) = stateful_matcher' σ'" for σ' by presburger  
  show ?thesis (is "?lhs  ?rhs")
    proof
      assume ?lhs thus ?rhs
        proof(induction rule: semantics_stateful.induct)
        case 1 thus ?case by(auto intro: semantics_stateful_packet_tagging_intro_start)[1]
        next
        case (2 built_in_chain default_policy p ps  ps_processed σ')
          from 2 have
            "semantics_stateful_packet_tagging rs stateful_matcher_tagged' packet_tagger' state_update' σ0 (built_in_chain, default_policy) (p # ps) ps_processed σ'"
            by blast
          with 2(2,3) show ?case
          apply -
          apply(rule semantics_stateful_packet_tagging_intro_process_one)
             apply(simp_all add: vs_tagged)
          done
       qed
    next
      assume ?rhs thus ?lhs
      proof(induction rule: semantics_stateful_packet_tagging.induct)
        case 1 thus ?case by(auto intro: semantics_stateful_intro_start)
        next
        case (2 built_in_chain default_policy p ps ps_processed σ') thus ?case
           apply -
           apply(rule semantics_stateful_intro_process_one)
              apply(simp_all add: stateful_matcher_eq vs_tagged)
           done
      qed
    qed
  qed


text‹Examples›
context
begin
subsection‹Example: Conntrack with curried matcher›
  text‹We illustrate stateful semantics with a simple example. We allow matching on the states New
  and Established. In addition, we introduce a primitive match to match on outgoing ssh packets (dst port = 22).
  The state is managed in a state table where accepted connections are remembered.›


  text‹SomePacket with source and destination port or something we don't know about›
  private datatype packet = SomePacket "nat × nat" | OtherPacket

  private datatype primitive_matches = New | Established | IsSSH

  text‹In the state, we remember the packets which belong to an established connection.›
  private datatype conntrack_state = State "packet set"

  text‹The stateful primitive matcher: It is given the current state table. 
    If match on @{const Established}, the packet must be known in the state table.
    If match on @{const New}, the packet must not be in the state table.
    If match on @{const IsSSH}, the dst port of the packet must be 22.›
  private fun stateful_matcher :: "conntrack_state  (primitive_matches, packet) matcher" where
    "stateful_matcher (State state_table) = (λm p. m = Established  p  state_table 
                                           m = New  p  state_table 
                                           m = IsSSH  (dst_port. p = SomePacket (22, dst_port)))"

  text‹Connections are always bi-directional.›
  private fun reverse_direction :: "packet  packet" where
    "reverse_direction OtherPacket = OtherPacket" |
    "reverse_direction (SomePacket (src, dst)) = SomePacket (dst,src)"

  text‹If a packet is accepted, the state for its bi-directional connection is saved in the state table.›
  private fun state_update' :: "conntrack_state  final_decision  packet  conntrack_state" where
    "state_update' (State state_table) FinalAllow p = State (state_table  {p, reverse_direction p})" |
    "state_update' (State state_table) FinalDeny p = State state_table"

  text‹Allow everything that is established and allow new ssh connections.
    Drop everything else (default policy, see below)›
  private definition "ruleset == [''INPUT''  [Rule (Match Established) Accept, Rule (MatchAnd (Match IsSSH) (Match New)) Accept]]"

  text‹The @{const ruleset} does not allow @{const OtherPacket}
  lemma "semantics_stateful ruleset stateful_matcher state_update' (State {}) (''INPUT'', Drop) []
    [(OtherPacket, FinalDeny)] (State {})"
    unfolding ruleset_def
    apply(rule semantics_stateful_intro_process_one)
        apply(simp_all)
       apply(rule semantics_stateful_intro_start)
        apply(simp_all)
     apply(rule seq_cons)
      apply(rule call_result)
        apply(simp_all)
      apply(rule seq_cons)
       apply(auto intro: iptables_bigstep.intros)
    done


  text‹The @{const ruleset} allows ssh packets, i.e. any packets with destination port 22 in the @{const New} rule.
        The state is updated such that everything which belongs to the connection will now be accepted.›
  lemma "semantics_stateful ruleset stateful_matcher state_update' (State {}) (''INPUT'', Drop)
          []
          [(SomePacket (22, 1024), FinalAllow)]
          (State {SomePacket (1024, 22), SomePacket (22, 1024)})"
    unfolding ruleset_def
    apply(rule semantics_stateful_intro_process_one)
        apply(simp_all)
       apply(rule semantics_stateful_intro_start)
        apply(simp_all)
     apply(rule seq_cons)
      apply(rule call_result)
        apply(simp_all)
      apply(rule seq_cons)
       apply(auto intro: iptables_bigstep.intros)
    done

  text‹If we continue with this state, answer packets are now allowed›
  lemma "semantics_stateful ruleset stateful_matcher state_update' (State {}) (''INPUT'', Drop)
          []
          [(SomePacket (22, 1024), FinalAllow), (SomePacket (1024, 22), FinalAllow)]
          (State {SomePacket (1024, 22), SomePacket (22, 1024)})"
    unfolding ruleset_def
    apply(rule semantics_stateful_intro_process_one)
        apply(simp_all)
      apply(rule semantics_stateful_intro_process_one)
         apply(simp_all)
        apply(rule semantics_stateful_intro_start)
         apply(simp_all)
      apply(rule seq_cons, rule call_result, simp_all, rule seq_cons)
        apply(auto intro: iptables_bigstep.intros)
    apply(rule seq_cons, rule call_result, simp_all, rule seq_cons)
      apply(auto intro: iptables_bigstep.intros)
    done

  text‹In contrast, without having previously established a state, answer packets are prohibited›
  text‹If we continue with this state, answer packets are now allowed›
  lemma "semantics_stateful ruleset stateful_matcher state_update' (State {}) (''INPUT'', Drop)
          []
          [(SomePacket (1024, 22), FinalDeny), (SomePacket (22, 1024), FinalAllow), (SomePacket (1024, 22), FinalAllow)]
          (State {SomePacket (1024, 22), SomePacket (22, 1024)})"
    unfolding ruleset_def
    apply(rule semantics_stateful_intro_process_one)
        apply(simp_all)
      apply(rule semantics_stateful_intro_process_one)
         apply(simp_all)
       apply(rule semantics_stateful_intro_process_one)
          apply(simp_all)
        apply(rule semantics_stateful_intro_start)
         apply(simp_all)
       apply(rule seq_cons, rule call_result, simp_all, rule seq_cons, auto intro: iptables_bigstep.intros)+
    done


subsection‹Example: Conntrack with packet tagging›

  datatype packet_tag = TagNew | TagEstablished
  datatype packet_tagged = SomePacket_tagged "nat × nat × packet_tag" | OtherPacket_tagged packet_tag

  fun get_packet_tag :: "packet_tagged  packet_tag" where
    "get_packet_tag (SomePacket_tagged (_,_, tag)) = tag" |
    "get_packet_tag (OtherPacket_tagged tag) = tag"

  definition stateful_matcher_tagged :: "(primitive_matches, packet_tagged) matcher" where
    "stateful_matcher_tagged  λm p. m = Established  (get_packet_tag p = TagEstablished) 
                                           m = New  (get_packet_tag p = TagNew) 
                                           m = IsSSH  (dst_port tag. p = SomePacket_tagged (22, dst_port, tag))"

  fun calculate_packet_tag :: "conntrack_state  packet  packet_tag" where
    "calculate_packet_tag (State state_table) p = (if p  state_table then TagEstablished else TagNew)"

  fun packet_tagger :: "conntrack_state  packet  packet_tagged" where
    "packet_tagger σ (SomePacket (s,d)) = (SomePacket_tagged (s,d, calculate_packet_tag σ (SomePacket (s,d))))" |
    "packet_tagger σ OtherPacket = (OtherPacket_tagged (calculate_packet_tag σ OtherPacket))"

  text‹If a packet is accepted, the state for its bi-directional connection is saved in the state table.›
  fun state_update_tagged :: "conntrack_state  final_decision  packet  conntrack_state" where
    "state_update_tagged (State state_table) FinalAllow p = State (state_table  {p, reverse_direction p})" |
    "state_update_tagged (State state_table) FinalDeny p = State state_table"


  
  text‹Both semantics are equal›
  lemma "semantics_stateful rs stateful_matcher state_update' σ0 start ps ps_processed σ' =
    semantics_stateful_packet_tagging rs stateful_matcher_tagged packet_tagger state_update' σ0 start ps ps_processed σ'"
    apply(rule semantics_stateful_vs_tagged)
    apply(intro allI, rename_tac m σ p)
    apply(case_tac σ)
    apply(case_tac p)
     apply(simp_all add: stateful_matcher_tagged_def)
    apply force
    done
end

end

Theory Semantics_Goto

theory Semantics_Goto
imports Main Firewall_Common "Common/List_Misc" "HOL-Library.LaTeXsugar"
begin

section‹Big Step Semantics with Goto›
text‹
  We extend the iptables semantics to support the goto action.
  A goto directly continues processing at the start of the called chain.
  It does not change the call stack.
  In contrast to calls, goto does not return.
  Consequently, everything behind a matching goto cannot be reached.
›
text‹
  This theory is structured as follows.
  Fist, the goto semantics are introduced.
  Then, we show that those semantics are deterministic.
  Finally, we present two methods to remove gotos.
   The first unfolds goto.
   The second replaces gotos with calls.
  Finally, since the goto rules makes all proofs quite ugly, we never mention the goto semantics again.
  As we have shown, we can get rid of the gotos easily, thus, we stick to the nicer iptables semantics without goto.
›

context
begin
  
  subsection‹Semantics›
    private type_synonym 'a ruleset = "string  'a rule list"
    
    private type_synonym ('a, 'p) matcher = "'a  'p  bool"
    
    qualified fun matches :: "('a, 'p) matcher  'a match_expr  'p  bool" where
      "matches γ (MatchAnd e1 e2) p  matches γ e1 p  matches γ e2 p" |
      "matches γ (MatchNot me) p  ¬ matches γ me p" |
      "matches γ (Match e) p  γ e p" |
      "matches _ MatchAny _  True"
    
    
    (*
    main:
      call foo
      deny-all
    foo:
      goto bar
    bar:
      [nothing]
    
    The call returns, even if a goto is executed in the called chains. The deny-all will be executed!
    
    Chain OUTPUT (policy ACCEPT 98 packets, 34936 bytes)
     pkts bytes target     prot opt in     out     source               destination         
        1    84            all  --  *      *       0.0.0.0/0            127.42.0.1          
        1    84 foo        all  --  *      *       0.0.0.0/0            127.42.0.1          
        1    84            all  --  *      *       0.0.0.0/0            127.42.0.1          
    
    Chain bar (1 references)
     pkts bytes target     prot opt in     out     source               destination         
    
    Chain foo (1 references)
     pkts bytes target     prot opt in     out     source               destination         
        1    84 bar        all  --  *      *       0.0.0.0/0            0.0.0.0/0           [goto] 
    
    *)
    qualified fun no_matching_Goto :: "('a, 'p) matcher  'p  'a rule list  bool" where
      "no_matching_Goto _ _ []  True" |
      "no_matching_Goto γ p ((Rule m (Goto _))#rs)  ¬ matches γ m p  no_matching_Goto γ p rs" |
      "no_matching_Goto γ p (_#rs)  no_matching_Goto γ p rs"
    
    inductive iptables_goto_bigstep :: "'a ruleset  ('a, 'p) matcher  'p  'a rule list  state  state  bool"
      ("_,_,_g _, _  _"  [60,60,60,20,98,98] 89)
      for Γ and γ and p where
    skip:    "Γ,γ,pg [], t  t" |
    accept:  "matches γ m p  Γ,γ,pg [Rule m Accept], Undecided  Decision FinalAllow" |
    drop:    "matches γ m p  Γ,γ,pg [Rule m Drop], Undecided  Decision FinalDeny" |
    reject:  "matches γ m p   Γ,γ,pg [Rule m Reject], Undecided  Decision FinalDeny" |
    log:     "matches γ m p  Γ,γ,pg [Rule m Log], Undecided  Undecided" |
    empty:   "matches γ m p  Γ,γ,pg [Rule m Empty], Undecided  Undecided" |
    nomatch: "¬ matches γ m p  Γ,γ,pg [Rule m a], Undecided  Undecided" |
    decision: "Γ,γ,pg rs, Decision X  Decision X" |
    seq:      "Γ,γ,pg rs1, Undecided  t; Γ,γ,pg rs2, t  t'; no_matching_Goto γ p rs1  Γ,γ,pg rs1@rs2, Undecided  t'" |
    call_return:  " matches γ m p; Γ chain = Some (rs1@[Rule m' Return]@rs2);
                     matches γ m' p; Γ,γ,pg rs1, Undecided  Undecided;
                     no_matching_Goto γ p rs1 
                     ― ‹we do not support a goto in the first part if you want to return›
                     ― ‹probably unhandled case:›
                     ― ‹‹main:›
                     ― ‹‹  call foo›
                     ― ‹‹foo:›
                     ― ‹‹  goto bar›
                     ― ‹‹bar:›
                     ― ‹  Return //returns to ‹call foo›
                     ― ‹But this would be a really awkward ruleset!›
                   Γ,γ,pg [Rule m (Call chain)], Undecided  Undecided" |
    call_result:  " matches γ m p; Γ chain = Some rs; Γ,γ,pg rs, Undecided  t  
                   Γ,γ,pg [Rule m (Call chain)], Undecided  t" | ― ‹goto handling here seems okay›
    goto_decision:  " matches γ m p; Γ chain = Some rs; Γ,γ,pg rs, Undecided  Decision X  
                   Γ,γ,pg (Rule m (Goto chain))#rest, Undecided  Decision X" |
    goto_no_decision:  " matches γ m p; Γ chain = Some rs; Γ,γ,pg rs, Undecided  Undecided  
                   Γ,γ,pg (Rule m (Goto chain))#rest, Undecided  Undecided"
    
    text‹
    The semantic rules again in pretty format:
    \begin{center}
    @{thm[mode=Axiom] skip [no_vars]}\\[1ex]
    @{thm[mode=Rule] accept [no_vars]}\\[1ex]
    @{thm[mode=Rule] drop [no_vars]}\\[1ex]
    @{thm[mode=Rule] reject [no_vars]}\\[1ex]
    @{thm[mode=Rule] log [no_vars]}\\[1ex]
    @{thm[mode=Rule] empty [no_vars]}\\[1ex]
    @{thm[mode=Rule] nomatch [no_vars]}\\[1ex]
    @{thm[mode=Rule] decision [no_vars]}\\[1ex]
    @{thm[mode=Rule] seq [no_vars]} \\[1ex]
    @{thm[mode=Rule] call_return [no_vars]}\\[1ex] 
    @{thm[mode=Rule] call_result [no_vars]}\\[1ex] 
    @{thm[mode=Rule] goto_decision [no_vars]}\\[1ex] 
    @{thm[mode=Rule] goto_no_decision [no_vars]}
    \end{center}
›
    
    private lemma deny:
      "matches γ m p  a = Drop  a = Reject  iptables_goto_bigstep Γ γ p [Rule m a] Undecided (Decision FinalDeny)"
    by (auto intro: drop reject)
    
    
    private lemma iptables_goto_bigstep_induct
      [case_names
        Skip Allow Deny Log Nomatch Decision Seq Call_return Call_result Goto_Decision Goto_no_Decision,
       induct pred: iptables_goto_bigstep]:
    " Γ,γ,pg rs,s  t;
       t. P [] t t;
       m a. matches γ m p  a = Accept  P [Rule m a] Undecided (Decision FinalAllow);
       m a. matches γ m p  a = Drop  a = Reject  P [Rule m a] Undecided (Decision FinalDeny);
       m a. matches γ m p  a = Log  a = Empty  P [Rule m a] Undecided Undecided;
       m a. ¬ matches γ m p  P [Rule m a] Undecided Undecided;
       rs X. P rs (Decision X) (Decision X);
       rs rs1 rs2 t t'. rs = rs1 @ rs2  Γ,γ,pg rs1,Undecided  t  P rs1 Undecided t  
                          Γ,γ,pg rs2,t  t'  P rs2 t t'  no_matching_Goto γ p rs1  
                          P rs Undecided t';
       m a chain rs1 m' rs2. matches γ m p  a = Call chain 
                              Γ chain = Some (rs1 @ [Rule m' Return] @ rs2) 
                              matches γ m' p  Γ,γ,pg rs1,Undecided  Undecided 
                              no_matching_Goto γ p rs1   P rs1 Undecided Undecided 
                              P [Rule m a] Undecided Undecided;
       m a chain rs t. matches γ m p  a = Call chain  Γ chain = Some rs 
                         Γ,γ,pg rs,Undecided  t  P rs Undecided t  P [Rule m a] Undecided t;
       m a chain rs rest X. matches γ m p  a = Goto chain  Γ chain = Some rs 
                              Γ,γ,pg rs,Undecided  (Decision X)  P rs Undecided (Decision X) 
                              P (Rule m a#rest) Undecided (Decision X);
       m a chain rs rest. matches γ m p  a = Goto chain  Γ chain = Some rs 
                           Γ,γ,pg rs,Undecided  Undecided  P rs Undecided Undecided 
                           P (Rule m a#rest) Undecided Undecided 
     P rs s t"
    by (induction rule: iptables_goto_bigstep.induct) auto


  
  subsubsection‹Forward reasoning›
  
    private lemma decisionD: "Γ,γ,pg r, s  t  s = Decision X  t = Decision X"
      by (induction rule: iptables_goto_bigstep_induct) auto
    
    private lemma iptables_goto_bigstep_to_undecided: "Γ,γ,pg rs, s  Undecided  s = Undecided"
      by (metis decisionD state.exhaust)
    
    private lemma iptables_goto_bigstep_to_decision: "Γ,γ,pg rs, Decision Y  Decision X  Y = X"
      by (metis decisionD state.inject)
    
    
    private lemma skipD: "Γ,γ,pg r, s  t  r = []  s = t"
      by (induction rule: iptables_goto_bigstep.induct) auto
    
    
    private lemma gotoD: "Γ,γ,pg r, s  t  r = [Rule m (Goto chain)]  s = Undecided  matches γ m p 
                     rs. Γ chain = Some rs  Γ,γ,pg rs,s  t"
      by (induction rule: iptables_goto_bigstep.induct) (auto dest: skipD elim: list_app_singletonE)
    
    private lemma not_no_matching_Goto_singleton_cases: "¬ no_matching_Goto γ p [Rule m a]  ( chain. a = (Goto chain))  matches γ m p"
      by(case_tac a) (simp_all)
    
    private lemma no_matching_Goto_Cons: "no_matching_Goto γ p [r]  no_matching_Goto γ p rs  no_matching_Goto γ p (r#rs)"
      by(cases r)(rename_tac m a, case_tac a, simp_all)
    
    private lemma no_matching_Goto_head: "no_matching_Goto γ p (r#rs)  no_matching_Goto γ p [r]"
      by(cases r)(rename_tac m a, case_tac a, simp_all)
    private lemma no_matching_Goto_tail: "no_matching_Goto γ p (r#rs)  no_matching_Goto γ p rs"
      by(cases r)(rename_tac m a, case_tac a, simp_all)
    
    private lemma not_no_matching_Goto_cases:
      assumes "¬ no_matching_Goto γ p rs" "rs  []"
      shows "rs1 m chain rs2. rs = rs1@(Rule m (Goto chain))#rs2  no_matching_Goto γ p rs1  matches γ m p"
        using assms
        proof(induction rs)
        case Nil thus ?case by simp
        next
        case (Cons r rs)
          note Cons_outer=this
          from Cons have "¬ no_matching_Goto γ p (r # rs)" by simp
          show ?case
          proof(cases rs)
          case Nil
            obtain m a where "r = Rule m a" by (cases r) simp
            with ¬ no_matching_Goto γ p (r # rs) Nil not_no_matching_Goto_singleton_cases have "( chain. a = (Goto chain))  matches γ m p" by metis
            from this obtain chain where "a = (Goto chain)" and "matches γ m p" by blast
            have "r # rs = [] @ Rule m (Goto chain) # []" "no_matching_Goto γ p []" "matches γ m p"
              by (simp_all add: a = Goto chain r = Rule m a Nil ‹matches γ m p)
            thus ?thesis by blast
          next
          case(Cons r' rs')
            with Cons_outer have "r # rs =  r # r' # rs'" by simp
            show ?thesis
            proof(cases"no_matching_Goto γ p [r]")
            case True 
              with ¬ no_matching_Goto γ p (r # rs) have "¬ no_matching_Goto γ p rs" by (meson no_matching_Goto_Cons)
              have "rs  []" using Cons by simp
              from Cons_outer(1)[OF ¬ no_matching_Goto γ p rs rs  []]
                obtain rs1 m chain rs2 where "rs = rs1 @ Rule m (Goto chain) # rs2" "no_matching_Goto γ p rs1" "matches γ m p" by blast
              with r # rs =  r # r' # rs' ‹no_matching_Goto γ p [r] no_matching_Goto_Cons
                  have "r # rs = r # rs1 @ Rule m (Goto chain) # rs2  no_matching_Goto γ p (r#rs1)  matches γ m p" by fast
              thus ?thesis
                apply(rule_tac x="r#rs1" in exI)
                by auto
            next
            case False
              obtain m a where "r = Rule m a" by (cases r) simp
              with False not_no_matching_Goto_singleton_cases have "( chain. a = (Goto chain))  matches γ m p" by metis
              from this obtain chain where "a = (Goto chain)" and "matches γ m p" by blast
              have "r # rs = [] @ Rule m (Goto chain) # rs" "no_matching_Goto γ p []" "matches γ m p"
                by (simp_all add: a = Goto chain r = Rule m a ‹matches γ m p)
              thus ?thesis by blast
            qed
          qed
        qed
    
    private lemma seq_cons_Goto_Undecided: 
      assumes "Γ,γ,pg [Rule m (Goto chain)], Undecided  Undecided"
      and "¬ matches γ m p  Γ,γ,pg rs, Undecided  Undecided"
      shows "Γ,γ,pg Rule m (Goto chain) # rs, Undecided  Undecided"
      proof(cases "matches γ m p")
        case True
          from True assms have "rs. Γ chain = Some rs  Γ,γ,pg rs, Undecided  Undecided" by(auto dest: gotoD)
          with True show ?thesis using goto_no_decision by fast
      next
        case False
        with assms have " Γ,γ,pg [Rule m (Goto chain)] @ rs, Undecided  Undecided" by(auto dest: seq)
        with False show ?thesis by simp
      qed

    private lemma seq_cons_Goto_t: 
      "Γ,γ,pg [Rule m (Goto chain)], Undecided  t  matches γ m p  Γ,γ,pg Rule m (Goto chain) # rs, Undecided  t"
       apply(frule gotoD)
          apply(simp_all)
       apply(clarify)
       apply(cases t)
        apply(auto intro: iptables_goto_bigstep.intros)
    done
    
    
    private lemma no_matching_Goto_append: "no_matching_Goto γ p (rs1@rs2)  no_matching_Goto γ p rs1   no_matching_Goto γ p rs2"
      by(induction γ p rs1 rule: no_matching_Goto.induct) (simp_all)
    
    private lemma no_matching_Goto_append1: "no_matching_Goto γ p (rs1@rs2)  no_matching_Goto γ p rs1"
      using no_matching_Goto_append by fast
    private lemma no_matching_Goto_append2: "no_matching_Goto γ p (rs1@rs2)  no_matching_Goto γ p rs2"
      using no_matching_Goto_append by fast
    
    private lemma seq_cons:
      assumes "Γ,γ,pg [r],Undecided  t" and "Γ,γ,pg rs,t  t'" and "no_matching_Goto γ p [r]"
      shows "Γ,γ,pg r#rs, Undecided  t'"
      proof -
        from assms have "Γ,γ,pg [r] @ rs, Undecided  t'" by (rule seq)
        thus ?thesis by simp
      qed
    
    context
      notes skipD[dest] list_app_singletonE[elim]
    begin
      lemma acceptD: "Γ,γ,pg r, s  t  r = [Rule m Accept]  matches γ m p  s = Undecided  t = Decision FinalAllow"
      by (induction rule: iptables_goto_bigstep.induct) auto
      
      lemma dropD: "Γ,γ,pg r, s  t  r = [Rule m Drop]  matches γ m p  s = Undecided  t = Decision FinalDeny"
      by (induction rule: iptables_goto_bigstep.induct) auto
      
      lemma rejectD: "Γ,γ,pg r, s  t  r = [Rule m Reject]  matches γ m p  s = Undecided  t = Decision FinalDeny"
      by (induction rule: iptables_goto_bigstep.induct) auto
      
      lemma logD: "Γ,γ,pg r, s  t  r = [Rule m Log]  matches γ m p  s = Undecided  t = Undecided"
      by (induction rule: iptables_goto_bigstep.induct) auto
      
      lemma emptyD: "Γ,γ,pg r, s  t  r = [Rule m Empty]  matches γ m p  s = Undecided  t = Undecided"
      by (induction rule: iptables_goto_bigstep.induct) auto
      
      lemma nomatchD: "Γ,γ,pg r, s  t  r = [Rule m a]  s = Undecided  ¬ matches γ m p  t = Undecided"
      by (induction rule: iptables_goto_bigstep.induct) auto
      
      lemma callD:
        assumes "Γ,γ,pg r, s  t" "r = [Rule m (Call chain)]" "s = Undecided" "matches γ m p" "Γ chain = Some rs"
        obtains "Γ,γ,pg rs,s  t"
              | rs1 rs2 m' where "rs = rs1 @ Rule m' Return # rs2" "matches γ m' p" "Γ,γ,pg rs1,s  Undecided" "no_matching_Goto γ p rs1" "t = Undecided"
        using assms
        proof (induction r s t arbitrary: rs rule: iptables_goto_bigstep.induct)
          case (seq rs1)
          thus ?case by (cases rs1) auto
        qed auto
    end
    
    private lemmas iptables_goto_bigstepD = skipD acceptD dropD rejectD logD emptyD nomatchD decisionD callD gotoD
    
    private lemma seq':
      assumes "rs = rs1 @ rs2" "Γ,γ,pg rs1,s  t" "Γ,γ,pg rs2,t  t'" and "no_matching_Goto γ p rs1"
      shows "Γ,γ,pg rs,s  t'"
      using assms by (cases s) (auto intro: seq decision dest: decisionD)
    
    
    private lemma seq'_cons: "Γ,γ,pg [r],s  t  Γ,γ,pg rs,t  t'  no_matching_Goto γ p [r]  Γ,γ,pg r#rs, s  t'"
      by (metis decision decisionD state.exhaust seq_cons)
    
    
    private lemma no_matching_Goto_take: "no_matching_Goto γ p rs  no_matching_Goto γ p  (take n rs)"
      apply(induction n arbitrary: rs)
       apply(simp_all)
      apply(rename_tac r rs)
      apply(case_tac rs)
       apply(simp_all)
      apply(rename_tac r' rs')
      apply(case_tac r')
      apply(simp)
      apply(rename_tac m a)
      by(case_tac a) (simp_all)
    
    private lemma seq_split:
      assumes "Γ,γ,pg rs, s  t" "rs = rs1@rs2"
      obtains (no_matching_Goto) t' where "Γ,γ,pg rs1,s  t'" "Γ,γ,pg rs2,t'  t" "no_matching_Goto γ p rs1"
            | (matching_Goto) "Γ,γ,pg rs1,s  t" "¬ no_matching_Goto γ p rs1"
    proof -
      have "(t'. Γ,γ,pg rs1,s  t'  Γ,γ,pg rs2,t'  t  no_matching_Goto γ p rs1)  (Γ,γ,pg rs1,s  t  ¬ no_matching_Goto γ p rs1)"
      using assms
      proof (induction rs s t arbitrary: rs1 rs2 rule: iptables_goto_bigstep_induct)
        case Skip thus ?case by (auto intro: iptables_goto_bigstep.intros simp add: accept)
      next
        case Allow thus ?case by (cases rs1) (auto intro: iptables_goto_bigstep.intros simp add: accept)
      next
        case Deny thus ?case by (cases rs1) (auto intro: iptables_goto_bigstep.intros simp add: deny)
      next
        case Log thus ?case by (cases rs1) (auto intro: iptables_goto_bigstep.intros simp add: log empty)
      next
        case Nomatch thus ?case by (cases rs1)
          (auto intro: iptables_goto_bigstep.intros simp add: not_no_matching_Goto_singleton_cases, meson nomatch not_no_matching_Goto_singleton_cases skip)
      next
        case Decision thus ?case by (auto intro: iptables_goto_bigstep.intros)
      next
        case (Seq rs rsa rsb t t')
        hence rs: "rsa @ rsb = rs1 @ rs2" by simp
        note List.append_eq_append_conv_if[simp]
        from rs show ?case
          proof (cases rule: list_app_eq_cases)
            case longer
            with Seq have t1: "Γ,γ,pg take (length rsa) rs1, Undecided  t"
              by simp
            from Seq.IH(2)[OF longer(2)] have IH:
              "(t'a. Γ,γ,pg drop (length rsa) rs1, t  t'a  Γ,γ,pg rs2, t'a  t'  no_matching_Goto γ p (drop (length rsa) rs1)) 
               Γ,γ,pg drop (length rsa) rs1, t  t'  ¬ no_matching_Goto γ p (drop (length rsa) rs1)" (is "?IH_no_Goto  ?IH_Goto") by simp
            thus ?thesis
              proof(rule disjE)
                assume IH: ?IH_no_Goto
                from IH obtain t2
                  where t2a: "Γ,γ,pg drop (length rsa) rs1,t  t2"
                    and rs_part2: "Γ,γ,pg rs2,t2  t'"
                    and "no_matching_Goto γ p (drop (length rsa) rs1)"
                  by blast
                with t1 rs_part2 have rs_part1: "Γ,γ,pg take (length rsa) rs1 @ drop (length rsa) rs1, Undecided  t2"
                  using Seq.hyps(4) longer(1) seq by fastforce
                have "no_matching_Goto γ p (take (length rsa) rs1 @ drop (length rsa) rs1)"
                  using Seq.hyps(4) ‹no_matching_Goto γ p (drop (length rsa) rs1) longer(1)
                        no_matching_Goto_append by fastforce 
                with Seq rs_part1 rs_part2 show ?thesis by auto
              next
                assume ?IH_Goto
                thus ?thesis by (metis Seq.hyps(2) Seq.hyps(4) append_take_drop_id longer(1) no_matching_Goto_append2 seq')
              qed
          next
            case shorter
            from shorter rs have rsa': "rsa = rs1 @ take (length rsa - length rs1) rs2"
              by (metis append_eq_conv_conj length_drop)
            from shorter rs have rsb': "rsb = drop (length rsa - length rs1) rs2"
              by (metis append_eq_conv_conj length_drop)
    
            from Seq.hyps(4) rsa' no_matching_Goto_append2 have
                no_matching_Goto_rs2: "no_matching_Goto γ p (take (length rsa - length rs1) rs2)" by metis
    
            from rsb' Seq.hyps have t2: "Γ,γ,pg drop (length rsa - length rs1) rs2,t  t'"
              by blast
    
            from Seq.IH(1)[OF rsa'] have IH:
              "(t'. Γ,γ,pg rs1, Undecided  t'  Γ,γ,pg take (length rsa - length rs1) rs2, t'  t  no_matching_Goto γ p rs1) 
                Γ,γ,pg rs1, Undecided  t  ¬ no_matching_Goto γ p rs1" (is "?IH_no_Goto  ?IH_Goto") by simp
    
            thus ?thesis
              proof(rule disjE)
                assume IH: ?IH_no_Goto
                from IH obtain t1
                  where t1a: "Γ,γ,pg rs1,Undecided  t1"
                    and t1b: "Γ,γ,pg take (length rsa - length rs1) rs2,t1  t"
                    and "no_matching_Goto γ p rs1"
                  by blast
        
                  from no_matching_Goto_rs2 t2 seq' t1b have rs2: "Γ,γ,pg rs2,t1  t'"
                    by  fastforce
                  from t1a rs2 ‹no_matching_Goto γ p rs1 show ?thesis by fast
              next
                assume ?IH_Goto
                thus ?thesis by (metis Seq.hyps(4) no_matching_Goto_append1 rsa') 
              qed
          qed
      next
        case Call_return
        hence "Γ,γ,pg rs1, Undecided  Undecided" "Γ,γ,pg rs2, Undecided  Undecided"
          by (case_tac [!] rs1) (auto intro: iptables_goto_bigstep.skip iptables_goto_bigstep.call_return)
        thus ?case by fast
      next
        case (Call_result _ _ _ _ t)
        show ?case
          proof (cases rs1)
            case Nil
            with Call_result have "Γ,γ,pg rs1, Undecided  Undecided" "Γ,γ,pg rs2, Undecided  t"
              by (auto intro: iptables_goto_bigstep.intros)
            thus ?thesis using local.Nil by auto 
          next
            case Cons
            with Call_result have "Γ,γ,pg rs1, Undecided  t" "Γ,γ,pg rs2, t  t"
              by (auto intro: iptables_goto_bigstep.intros)
            thus ?thesis by fast
          qed
      next
        case (Goto_Decision m a chain rs rest X)
        thus ?case
          proof (cases rs1)
            case Nil
            with Goto_Decision have "Γ,γ,pg rs1, Undecided  Undecided" "Γ,γ,pg rs2, Undecided  Decision X"
              by (auto intro: iptables_goto_bigstep.intros)
            thus ?thesis using local.Nil by auto
          next
            case Cons
            with Goto_Decision have "Γ,γ,pg rs1, Undecided  Decision X" "Γ,γ,pg rs2, Decision X  Decision X"
              by (auto intro: iptables_goto_bigstep.intros) 
            thus ?thesis by fast
          qed
      next
        case (Goto_no_Decision m a chain rs rest rs1)
        from Goto_no_Decision have rs1rs2: "Rule m (Goto chain) # rest = rs1 @ rs2" by simp
        from goto_no_decision[OF Goto_no_Decision(1)]  Goto_no_Decision(3)  Goto_no_Decision(4)
          have x: "rest. Γ,γ,pg Rule m (Goto chain) # rest, Undecided  Undecided" by simp
        show ?case
          proof (cases rs1)
            case Nil
            with Goto_no_Decision have "Γ,γ,pg rs1, Undecided  Undecided" "Γ,γ,pg rs2, Undecided  Undecided"
              by (auto intro: iptables_goto_bigstep.intros)
            thus ?thesis by fast
          next
            case (Cons rs1a rs1s)
            with rs1rs2 have "rs1 = Rule m (Goto chain) # (take (length rs1s) rest)" by simp
            from Cons rs1rs2 have"rs2 = drop (length rs1s) rest" by simp
            
            from Cons Goto_no_Decision have 1: "Γ,γ,pg rs1, Undecided  Undecided"
              using x by auto[1]
            have 2: "¬ no_matching_Goto γ p rs1"
              by (simp add: Goto_no_Decision.hyps(1) rs1 = Rule m (Goto chain) # take (length rs1s) rest) 
            from 1 2 show ?thesis by fast
          qed
      qed
    thus ?thesis using matching_Goto no_matching_Goto by blast 
    qed
    
    private lemma seqE:
      assumes "Γ,γ,pg rs1@rs2, s  t"
      obtains (no_matching_Goto) ti where "Γ,γ,pg rs1,s  ti" "Γ,γ,pg rs2,ti  t" "no_matching_Goto γ p rs1"
            | (matching_Goto) "Γ,γ,pg rs1,s  t" "¬ no_matching_Goto γ p rs1"
      using assms by (force elim: seq_split)
    
    private lemma seqE_cons:
      assumes "Γ,γ,pg r#rs, s  t"
      obtains (no_matching_Goto) ti where "Γ,γ,pg [r],s  ti" "Γ,γ,pg rs,ti  t" "no_matching_Goto γ p [r]"
            | (matching_Goto) "Γ,γ,pg [r],s  t" "¬ no_matching_Goto γ p [r]"
      using assms by (metis append_Cons append_Nil seqE)
    
    private lemma seqE_cons_Undecided:
      assumes "Γ,γ,pg r#rs, Undecided  t"
      obtains (no_matching_Goto) ti where "Γ,γ,pg [r],Undecided  ti" and "Γ,γ,pg rs,ti  t" and "no_matching_Goto γ p [r]"
            | (matching_Goto) m chain rs' where "r = Rule m (Goto chain)" and "Γ,γ,pg [Rule m (Goto chain)],Undecided  t" and "matches γ m p" "Γ chain = Some rs'"
      using assms
      proof(cases rule: seqE_cons)
      case no_matching_Goto thus ?thesis using local.that by simp
      next
      case matching_Goto
        from this(2) not_no_matching_Goto_singleton_cases[of γ p "(get_match r)" "(get_action r)", simplified] have
          "((chain. (get_action r) = Goto chain)  matches γ (get_match r) p)" by simp
        from this obtain chain m where r: "r = Rule m (Goto chain)" "matches γ m p" by(cases r) auto
        from matching_Goto r have "Γ,γ,pg [Rule m (Goto chain)],Undecided  t" by simp
        from gotoD[OF matching_Goto(1)] r ‹matches γ m p obtain rs' where "Γ chain = Some rs'" by blast
      from local.that 
      show ?thesis using Γ chain = Some rs' Γ,γ,pg [Rule m (Goto chain)], Undecided  t r(1) r(2) by blast
    qed
    
    private lemma nomatch':
      assumes "r. r  set rs  ¬ matches γ (get_match r) p"
      shows "Γ,γ,pg rs, s  s"
      proof(cases s)
        case Undecided
        have "rset rs. ¬ matches γ (get_match r) p  Γ,γ,pg rs, Undecided  Undecided"
          proof(induction rs)
            case Nil
            thus ?case by (fast intro: skip)
          next
            case (Cons r rs)
            hence "Γ,γ,pg [r], Undecided  Undecided"
              by (cases r) (auto intro: nomatch)
            with Cons show ?case
              by (metis list.set_intros(1) list.set_intros(2) not_no_matching_Goto_singleton_cases rule.collapse seq'_cons)
          qed
        with assms Undecided show ?thesis by simp
      qed (blast intro: decision)
    
    private lemma no_free_return: assumes "Γ,γ,pg [Rule m Return], Undecided  t" and "matches γ m p" shows "False"
      proof -
      { fix a s
        have no_free_return_hlp: "Γ,γ,pg a,s  t  matches γ m p   s = Undecided  a = [Rule m Return]  False"
        proof (induction rule: iptables_goto_bigstep.induct)
          case (seq rs1)
          thus ?case
            by (cases rs1) (auto dest: skipD)
        qed simp_all
      } with assms show ?thesis by blast
      qed
  
  subsection‹Determinism›
    private lemma iptables_goto_bigstep_Undecided_Undecided_deterministic: 
      "Γ,γ,pg rs, Undecided  Undecided  Γ,γ,pg rs, Undecided  t  t = Undecided"
    proof(induction rs Undecided Undecided arbitrary: t rule: iptables_goto_bigstep_induct)
      case Skip thus ?case by(fastforce  dest: skipD logD emptyD nomatchD decisionD)
      next
      case Log thus ?case by(fastforce  dest: skipD logD emptyD nomatchD decisionD)
      next
      case Nomatch thus ?case by(fastforce  dest: skipD logD emptyD nomatchD decisionD)
      next
      case Seq thus ?case by (metis iptables_goto_bigstep_to_undecided seqE)
      next
      case (Call_return m a chain rs1 m' rs2) 
        from Call_return have " Γ,γ,pg [Rule m (Call chain)], Undecided  Undecided"
          apply(frule_tac rs1=rs1 and m'=m' and chain=chain in call_return)
              by(simp_all)
        with Call_return show ?case
          apply simp
          apply (metis callD no_free_return seqE seqE_cons)
          done
      next
      case Call_result thus ?case by (meson callD)
      next
      case Goto_no_Decision thus ?case by (metis gotoD no_matching_Goto.simps(2) option.sel seqE_cons)
    qed
    
    private lemma iptables_goto_bigstep_Undecided_deterministic:
      "Γ,γ,pg rs, Undecided  t  Γ,γ,pg rs, Undecided  t'   t' = t"
    proof(induction rs Undecided t arbitrary: t' rule: iptables_goto_bigstep_induct)
      case Skip thus ?case by(fastforce  dest: skipD logD emptyD nomatchD decisionD)
      next
      case Allow thus ?case by (auto dest: iptables_goto_bigstepD)
      next
      case Deny thus ?case by (auto dest: iptables_goto_bigstepD)
      next
      case Log thus ?case by (auto dest: iptables_goto_bigstepD)
      next
      case Nomatch thus ?case by (auto dest: iptables_goto_bigstepD)
      next
      case Seq thus ?case by (metis decisionD seqE state.exhaust)
      next
      case Call_return thus ?case by (meson call_return iptables_goto_bigstep_Undecided_Undecided_deterministic)
      next
      case Call_result thus ?case by (metis callD call_result iptables_goto_bigstep_Undecided_Undecided_deterministic)
      next
      case Goto_Decision thus ?case by (metis gotoD no_matching_Goto.simps(2) option.sel seqE_cons)
      next
      case Goto_no_Decision thus ?case by (meson goto_no_decision iptables_goto_bigstep_Undecided_Undecided_deterministic)
    qed
    
    qualified theorem iptables_goto_bigstep_deterministic: assumes "Γ,γ,pg rs, s  t" and "Γ,γ,pg rs, s  t'" shows "t = t'"
    using assms
      apply(cases s)
       apply(simp add: iptables_goto_bigstep_Undecided_deterministic)
      by(auto dest: decisionD)
  
  subsection‹Matching›
    
    private lemma matches_rule_and_simp_help:
      assumes "matches γ m p"
      shows "Γ,γ,pg [Rule (MatchAnd m m') a'], s  t  Γ,γ,pg [Rule m' a'], s  t" (is "?l ?r")
      proof
        assume ?l thus ?r
          by (induction "[Rule (MatchAnd m m') a']" s t rule: iptables_goto_bigstep_induct)
             (auto intro: iptables_goto_bigstep.intros simp: assms Cons_eq_append_conv dest: skipD)
      next
        assume ?r thus ?l
          by (induction "[Rule m' a']" s t rule: iptables_goto_bigstep_induct)
             (auto intro: iptables_goto_bigstep.intros simp: assms Cons_eq_append_conv dest: skipD)
      qed
    
    private lemma matches_MatchNot_simp: 
      assumes "matches γ m p"
      shows "Γ,γ,pg [Rule (MatchNot m) a], Undecided  t  Γ,γ,pg [], Undecided  t" (is "?l  ?r")
      proof
        assume ?l thus ?r
          by (induction "[Rule (MatchNot m) a]" "Undecided" t rule: iptables_goto_bigstep_induct)
             (auto intro: iptables_goto_bigstep.intros simp: assms Cons_eq_append_conv dest: skipD)
      next
        assume ?r
        hence "t = Undecided"
          by (metis skipD)
        with assms show ?l
          by (fastforce intro: nomatch)
      qed
    
    private lemma matches_MatchNotAnd_simp:
      assumes "matches γ m p"
      shows "Γ,γ,pg [Rule (MatchAnd (MatchNot m) m') a], Undecided  t  Γ,γ,pg [], Undecided  t" (is "?l  ?r")
      proof
        assume ?l thus ?r
          by (induction "[Rule (MatchAnd (MatchNot m) m') a]" "Undecided" t rule: iptables_goto_bigstep_induct)
             (auto intro: iptables_goto_bigstep.intros simp add: assms Cons_eq_append_conv dest: skipD)
      next
        assume ?r
        hence "t = Undecided"
          by (metis skipD)
        with assms show ?l
          by (fastforce intro: nomatch)
      qed
      
    private lemma matches_rule_and_simp:
      assumes "matches γ m p"
      shows "Γ,γ,pg [Rule (MatchAnd m m') a'], s  t  Γ,γ,pg [Rule m' a'], s  t"
      proof (cases s)
        case Undecided
        with assms show ?thesis
          by (simp add: matches_rule_and_simp_help)
      next
        case Decision
        thus ?thesis by (metis decision decisionD)
      qed
    
    
    
    qualified definition add_match :: "'a match_expr  'a rule list  'a rule list" where
      "add_match m rs = map (λr. case r of Rule m' a'  Rule (MatchAnd m m') a') rs"
    
    private lemma add_match_split: "add_match m (rs1@rs2) = add_match m rs1 @ add_match m rs2"
      unfolding add_match_def
      by (fact map_append)
    
    private lemma add_match_split_fst: "add_match m (Rule m' a' # rs) = Rule (MatchAnd m m') a' # add_match m rs"
      unfolding add_match_def
      by simp
    
    private lemma matches_add_match_no_matching_Goto_simp: "matches γ m p  no_matching_Goto γ p (add_match m rs)  no_matching_Goto γ p rs"
      apply(induction rs)
       apply(simp_all)
      apply(rename_tac r rs)
      apply(case_tac r)
      apply(simp add: add_match_split_fst no_matching_Goto_tail)
      apply(drule no_matching_Goto_head)
      apply(rename_tac m' a')
      apply(case_tac a')
              apply simp_all
      done
    
    
    private lemma matches_add_match_no_matching_Goto_simp2: "matches γ m p   no_matching_Goto γ p rs  no_matching_Goto γ p (add_match m rs)"
      apply(induction rs)
       apply(simp add: add_match_def)
      apply(rename_tac r rs)
      apply(case_tac r)
      apply(simp add: add_match_split_fst no_matching_Goto_tail)
      apply(rename_tac m' a')
      apply(case_tac a')
              apply simp_all
      done
    
    private lemma matches_add_match_MatchNot_no_matching_Goto_simp: "¬ matches γ m p  no_matching_Goto γ p (add_match m rs)"
      apply(induction rs)
       apply(simp add: add_match_def)
      apply(rename_tac r rs)
      apply(case_tac r)
      apply(simp add: add_match_split_fst no_matching_Goto_tail)
      apply(rename_tac m' a')
      apply(case_tac a')
              apply simp_all
      done
    
    
    private lemma not_matches_add_match_simp:
      assumes "¬ matches γ m p"
      shows "Γ,γ,pg add_match m rs, Undecided  t  Γ,γ,pg [], Undecided  t"
      proof(induction rs)
      case Nil thus ?case unfolding add_match_def by simp
      next
      case (Cons r rs)
        obtain m' a where r: "r = Rule m' a" by(cases r, simp)
        let ?lhs="Γ,γ,pg Rule (MatchAnd m m') a # add_match m rs, Undecided  t"
        let ?rhs="Γ,γ,pg [], Undecided  t"
        { assume ?lhs
          from ?lhs Cons have ?rhs
           proof(cases  Γ γ p "Rule (MatchAnd m m') a" "add_match m rs"  t rule: seqE_cons_Undecided)
           case (no_matching_Goto ti)
             hence "ti = Undecided"  by (simp add: assms nomatchD)
             with no_matching_Goto Cons show ?thesis by simp
           next
           case (matching_Goto) with Cons assms show ?thesis by force
         qed
        } note 1=this
        { assume ?rhs
          hence "t = Undecided" using skipD by metis
          with Cons.IH ?rhs have ?lhs 
           by (meson assms matches.simps(1) nomatch not_no_matching_Goto_singleton_cases seq_cons)  
        } with 1 show ?case by(auto simp add: r add_match_split_fst)
      qed
    
    private lemma matches_add_match_MatchNot_simp:
      assumes m: "matches γ m p"
      shows "Γ,γ,pg add_match (MatchNot m) rs, s  t  Γ,γ,pg [], s  t" (is "?l s  ?r s")
      proof (cases s)
        case Undecided
        have "?l Undecided  ?r Undecided"
          proof
            assume "?l Undecided" with m show "?r Undecided"
              proof (induction rs)
                case Nil
                thus ?case
                  unfolding add_match_def by simp
              next
                case (Cons r rs)
                thus ?case
                  by (cases r) (metis matches_MatchNotAnd_simp skipD seqE_cons add_match_split_fst)
              qed
          next
            assume "?r Undecided" with m show "?l Undecided"
              proof (induction rs)
                case Nil
                thus ?case
                  unfolding add_match_def by simp
              next
                case (Cons r rs)
                hence "t = Undecided" using skipD by metis
                with Cons show ?case
                  apply (cases r)
                  apply(simp add: add_match_split_fst)
                  by (metis matches.simps(1) matches.simps(2) matches_MatchNotAnd_simp not_no_matching_Goto_singleton_cases seq_cons)
              qed
          qed
        with Undecided show ?thesis by fast
      next
        case (Decision d)
        thus ?thesis
          by(metis decision decisionD)
      qed
    
    
    private lemma just_show_all_bigstep_semantics_equalities_with_start_Undecided: 
          "Γ,γ,pg rs1, Undecided  t  Γ,γ,pg rs2, Undecided  t  
           Γ,γ,pg rs1, s  t  Γ,γ,pg rs2, s  t"
      apply(cases s)
       apply(simp)
      apply(simp)
      using decision decisionD by fastforce
      
    private lemma matches_add_match_simp_helper:
      assumes m: "matches γ m p"
      shows "Γ,γ,pg add_match m rs, Undecided  t  Γ,γ,pg rs, Undecided  t" (is "?l  ?r")
      proof
        assume ?l with m show ?r
          proof (induction rs)
            case Nil
            thus ?case
              unfolding add_match_def by simp
          next
            case (Cons r rs)
             obtain m' a where r: "r = Rule m' a" by(cases r, simp)
             from Cons have " Γ,γ,pg Rule (MatchAnd m m') a # add_match m rs, Undecided  t"
               by(simp add: r add_match_split_fst)
             from this Cons have "Γ,γ,pg Rule m' a # rs, Undecided  t"
             proof(cases rule: seqE_cons_Undecided)
               case (no_matching_Goto ti)
                from no_matching_Goto(3) Cons.prems(1) not_no_matching_Goto_singleton_cases
                  have "no_matching_Goto γ p [Rule m' a]" by (metis matches.simps(1))
                with no_matching_Goto Cons show ?thesis
                 apply(simp add: matches_rule_and_simp)
                 apply(cases ti)
                  apply (simp add: seq'_cons)
                 by (metis decision decisionD seq'_cons)
               next
               case (matching_Goto) with Cons show ?thesis
                apply(clarify)
                apply(simp add: matches_rule_and_simp_help)
                by (simp add: seq_cons_Goto_t)
             qed
             thus ?case by(simp add: r)
          qed
      next
        assume ?r with m show ?l
          proof (induction rs)
            case Nil
            thus ?case
              unfolding add_match_def by simp
          next
            case (Cons r rs)
             obtain m' a where r: "r = Rule m' a" by(cases r, simp)
             from Cons have "Γ,γ,pg Rule m' a # rs, Undecided  t" by(simp add: r)
             from this have "Γ,γ,pg Rule (MatchAnd m m') a # add_match m rs, Undecided  t"
                proof(cases Γ γ p "Rule m' a" rs t rule: seqE_cons_Undecided)
                case (no_matching_Goto ti)
                  from no_matching_Goto Cons.prems matches_rule_and_simp[symmetric] have
                    "Γ,γ,pg [Rule (MatchAnd m m') a], Undecided  ti" by fast
                  with Cons.prems Cons.IH no_matching_Goto show ?thesis
                   apply(cases ti)
                    apply (metis matches.simps(1) not_no_matching_Goto_singleton_cases seq_cons)
                   apply (metis decision decisionD matches.simps(1) not_no_matching_Goto_singleton_cases seq_cons)
                   done
                next
                case (matching_Goto) with Cons show ?thesis
                  by (simp add: matches_rule_and_simp_help seq_cons_Goto_t)
             qed
             thus ?case by(simp add: r add_match_split_fst)
          qed
      qed
    
    
    private lemma matches_add_match_simp:
      "matches γ m p  Γ,γ,pg add_match m rs, s  t  Γ,γ,pg rs, s  t"
      apply(rule just_show_all_bigstep_semantics_equalities_with_start_Undecided)
      by(simp add: matches_add_match_simp_helper)
    
    private lemma not_matches_add_matchNot_simp:
      "¬ matches γ m p  Γ,γ,pg add_match (MatchNot m) rs, s  t  Γ,γ,pg rs, s  t"
      by (simp add: matches_add_match_simp)
    
  subsection‹Goto Unfolding›
    private lemma unfold_Goto_Undecided:
        assumes chain_defined: "Γ chain = Some rs" and no_matching_Goto_rs: "no_matching_Goto γ p rs"
        shows "Γ,γ,pg (Rule m (Goto chain))#rest, Undecided  t  Γ,γ,pg add_match m rs @ add_match (MatchNot m) rest, Undecided  t"
              (is "?l  ?r")
    proof
      assume ?l
      thus ?r
        proof(cases rule: seqE_cons_Undecided)
        case (no_matching_Goto ti)
          from no_matching_Goto have "¬ matches γ m p" by simp
          with no_matching_Goto have ti: "ti = Undecided" using nomatchD by metis
          from ¬ matches γ m p have "Γ,γ,pg add_match m rs, Undecided  Undecided"
            using not_matches_add_match_simp skip by fast
          from ¬ matches γ m p matches_add_match_MatchNot_no_matching_Goto_simp have "no_matching_Goto γ p (add_match m rs)" by force
          from no_matching_Goto ti have "Γ,γ,pg rest, Undecided  t" by simp
          with not_matches_add_matchNot_simp[OF ¬ matches γ m p] have "Γ,γ,pg add_match (MatchNot m) rest, Undecided  t" by simp
          show ?thesis
            by (meson Γ,γ,pg add_match (MatchNot m) rest, Undecided  t Γ,γ,pg add_match m rs, Undecided  Undecided› ‹no_matching_Goto γ p (add_match m rs) seq)
        next
        case (matching_Goto m chain rs')
          from matching_Goto gotoD assms have "Γ,γ,pg rs, Undecided  t" by fastforce
          hence 1: "Γ,γ,pg add_match m rs, Undecided  t" by (simp add: matches_add_match_simp matching_Goto(3))
          have 2: "Γ,γ,pg add_match (MatchNot m) rest, t  t" by (simp add: matches_add_match_MatchNot_simp matching_Goto(3) skip)
          from no_matching_Goto_rs matches_add_match_no_matching_Goto_simp2 matching_Goto have 3: "no_matching_Goto γ p (add_match m rs)" by fast
          from 1 2 3 show ?thesis using matching_Goto(1) seq by fastforce
        qed
    next
      assume ?r
      thus ?l
        proof(cases "matches γ m p")
        case True
          have "Γ,γ,pg rs, Undecided  t"
            by (metis True Γ,γ,pg add_match m rs @ add_match (MatchNot m) rest, Undecided  t
                matches_add_match_MatchNot_simp matches_add_match_simp_helper self_append_conv seq' seqE)
          show ?l
          apply(cases t)
           using goto_no_decision[OF True] chain_defined apply (metis Γ,γ,pg rs, Undecided  t)
          using goto_decision[OF True, of Γ chain rs _ rest] chain_defined apply (metis Γ,γ,pg rs, Undecided  t)
          done
        next
        case False
          with ?r have "Γ,γ,pg add_match (MatchNot m) rest, Undecided  t"
            by (metis matches_add_match_MatchNot_no_matching_Goto_simp not_matches_add_match_simp seqE skipD)
          with False have "Γ,γ,pg rest, Undecided  t" by (meson not_matches_add_matchNot_simp) 
          show ?l by (meson False Γ,γ,pg rest, Undecided  t nomatch not_no_matching_Goto_singleton_cases seq_cons)
        qed
    qed
    
    
    (*
    This theorem allows us to unfold the deepest goto in a ruleset.
    This can be iterated to get to the higher-level gotos.
    *)
    qualified theorem unfold_Goto:
        assumes chain_defined: "Γ chain = Some rs" and no_matching_Goto_rs: "no_matching_Goto γ p rs"
        shows "Γ,γ,pg (Rule m (Goto chain))#rest, s  t  Γ,γ,pg add_match m rs @ add_match (MatchNot m) rest, s  t"
      apply(rule just_show_all_bigstep_semantics_equalities_with_start_Undecided)
      using assms unfold_Goto_Undecided by fast
    
    
    
    text‹A chain that will definitely come to a direct decision›
    qualified fun terminal_chain :: "'a rule list  bool" where
      "terminal_chain [] = False" |
      "terminal_chain [Rule MatchAny Accept] = True" |
      "terminal_chain [Rule MatchAny Drop] = True" |
      "terminal_chain [Rule MatchAny Reject] = True" |
      "terminal_chain ((Rule _ (Goto _))#rs) = False" |
      "terminal_chain ((Rule _ (Call _))#rs) = False" |
      "terminal_chain ((Rule _ Return)#rs) = False" |
      "terminal_chain ((Rule _ Unknown)#rs) = False" |
      "terminal_chain (_#rs) = terminal_chain rs"
    
    private lemma terminal_chain_no_matching_Goto: "terminal_chain rs  no_matching_Goto γ p rs"
       by(induction rs rule: terminal_chain.induct)  simp_all
    
    text‹A terminal chain means (if the semantics are actually defined) that the chain will
         ultimately yield a final filtering decision, for all packets.›
    qualified lemma "terminal_chain rs  Γ,γ,pg rs, Undecided  t  X. t = Decision X"
            apply(induction rs)
             apply(simp)
            apply(rename_tac r rs)
            apply(case_tac r)
            apply(rename_tac m a)
            apply(simp)
            apply(frule_tac γ=γ and p=p in terminal_chain_no_matching_Goto)
            apply(case_tac a)
                    apply(simp_all)
                apply(erule seqE_cons, simp_all,
                       metis iptables_goto_bigstepD matches.elims terminal_chain.simps terminal_chain.simps terminal_chain.simps)+
            done
    
    private lemma replace_Goto_with_Call_in_terminal_chain_Undecided:
        assumes chain_defined: "Γ chain = Some rs" and terminal_chain: "terminal_chain rs"
        shows "Γ,γ,pg [Rule m (Goto chain)], Undecided  t  Γ,γ,pg [Rule m (Call chain)], Undecided  t"
              (is "?l  ?r")
      proof
        assume ?l
        thus ?r
          proof(cases rule: seqE_cons_Undecided)
          case (no_matching_Goto ti)
            from no_matching_Goto have "¬ matches γ m p" by simp
            with nomatch have 1: "Γ,γ,pg [Rule m (Goto chain)], Undecided  Undecided" by fast
            from ¬ matches γ m p nomatch have 2: "Γ,γ,pg [Rule m (Call chain)], Undecided  Undecided" by fast
            from 1 2 show ?thesis
              using ?l iptables_goto_bigstep_Undecided_Undecided_deterministic by fastforce 
          next
          case (matching_Goto m chain rs')
            from matching_Goto gotoD assms have "Γ,γ,pg rs, Undecided  t" by fastforce
            from call_result[OF ‹matches γ m p chain_defined Γ,γ,pg rs, Undecided  t] show ?thesis
              by (metis matching_Goto(1) rule.sel(1))
          qed
      next
        assume ?r
        thus ?l
          proof(cases "matches γ m p")
          case True
            {fix rs1::"'a rule list" and  m' and rs2
              have "terminal_chain (rs1 @ Rule m' Return # rs2)  False"
              apply(induction rs1)
               apply(simp_all)
              apply(rename_tac r' rs')
              apply(case_tac r')
              apply(rename_tac m a)
              apply(simp_all)
              apply(case_tac a)
                      apply(simp_all)
                apply (metis append_is_Nil_conv hd_Cons_tl terminal_chain.simps)+
              done
            } note no_return=this
            have "Γ,γ,pg rs, Undecided  t"
              apply(rule callD[OF ?r _ _ True chain_defined])
                 apply(simp_all)
              using no_return terminal_chain by blast
            show ?l
              apply(cases t)
               using goto_no_decision[OF True] chain_defined apply (metis Γ,γ,pg rs, Undecided  t)
              using goto_decision[OF True, of Γ chain rs _ "[]"] chain_defined apply (metis Γ,γ,pg rs, Undecided  t)
              done
          next
          case False
            show ?l using False Γ,γ,pg [Rule m (Call chain)], Undecided  t nomatch nomatchD by fastforce 
          qed
      qed
    
  
  qualified theorem replace_Goto_with_Call_in_terminal_chain:
        assumes chain_defined: "Γ chain = Some rs" and terminal_chain: "terminal_chain rs"
        shows "Γ,γ,pg [Rule m (Goto chain)], s  t  Γ,γ,pg [Rule m (Call chain)], s  t"
      apply(rule just_show_all_bigstep_semantics_equalities_with_start_Undecided)
      using assms replace_Goto_with_Call_in_terminal_chain_Undecided by fast
  

  qualified fun rewrite_Goto_chain_safe :: "(string  'a rule list)  'a rule list  ('a rule list) option" where
    "rewrite_Goto_chain_safe _ [] = Some []" |
    "rewrite_Goto_chain_safe Γ ((Rule m (Goto chain))#rs) =
      (case (Γ chain) of None      None
                      |  Some rs'  (if
                                         ¬ terminal_chain rs'
                                      then
                                         None
                                      else
                                         map_option (λrs. Rule m (Call chain) # rs) (rewrite_Goto_chain_safe Γ rs)
                                     )
      )" |
    "rewrite_Goto_chain_safe Γ (r#rs) = map_option (λrs. r # rs) (rewrite_Goto_chain_safe Γ rs)"

  private fun rewrite_Goto_safe_internal
    :: "(string × 'a rule list) list  (string × 'a rule list) list  (string × 'a rule list) list option" where
    "rewrite_Goto_safe_internal _ [] = Some []" |
    "rewrite_Goto_safe_internal Γ ((chain_name, rs)#cs) = 
                (case rewrite_Goto_chain_safe (map_of Γ) rs of
                         None  None
                       | Some rs'  map_option (λrst. (chain_name, rs')#rst) (rewrite_Goto_safe_internal Γ cs)
                )"

  qualified fun rewrite_Goto_safe :: "(string × 'a rule list) list  (string × 'a rule list) list option" where
    "rewrite_Goto_safe cs = rewrite_Goto_safe_internal cs cs"


  (*use rewrite_Goto_chain_safe whenever possible!*)
  qualified definition rewrite_Goto :: "(string × 'a rule list) list  (string × 'a rule list) list" where
    "rewrite_Goto cs = the (rewrite_Goto_safe cs)"


  private lemma step_IH_cong: "(s. Γ,γ,pg rs1, s  t = Γ,γ,pg rs2, s  t) 
         Γ,γ,pg r#rs1, s  t = Γ,γ,pg r#rs2, s  t"
  apply(rule iffI)
   apply(erule seqE_cons)
    apply(rule seq'_cons)
      apply simp_all
   apply(drule not_no_matching_Goto_cases)
    apply(simp; fail)
   apply(elim exE conjE, rename_tac rs1a m chain rs2a)
   apply(subgoal_tac "r = Rule m (Goto chain)")
    prefer 2
    subgoal by (simp add: Cons_eq_append_conv)
   apply(thin_tac "[r] = _ @ Rule m (Goto chain) # _")
   apply simp
   apply (metis decision decisionD seq_cons_Goto_t state.exhaust)
  apply(erule seqE_cons)
   apply(rule seq'_cons)
     apply simp_all
  apply(drule not_no_matching_Goto_cases)
   apply(simp; fail)
  apply(elim exE conjE, rename_tac rs1a m chain rs2a)
  apply(subgoal_tac "r = Rule m (Goto chain)")
   prefer 2
   subgoal by (simp add: Cons_eq_append_conv)
  apply(thin_tac "[r] = _ @ Rule m (Goto chain) # _")
  apply simp
  apply (metis decision decisionD seq_cons_Goto_t state.exhaust)
  done

  private lemma terminal_chain_decision: 
    "terminal_chain rs  Γ,γ,pg rs, Undecided  t  X. t = Decision X"
    apply(induction rs arbitrary: t rule: terminal_chain.induct)
                                         apply simp_all
                                    apply(auto dest: iptables_goto_bigstepD)[3]
                                 apply(erule seqE_cons, simp_all, blast dest: iptables_goto_bigstepD)+ (*6s*)
    done
    

  private lemma terminal_chain_Goto_decision: "Γ chain = Some rs  terminal_chain rs  matches γ m p 
       Γ,γ,pg [Rule m (Goto chain)], s  t  X. t = Decision X"
    apply(cases s)
     apply(drule gotoD, simp_all)
     apply(elim exE conjE, simp_all)
     using terminal_chain_decision apply fast
    by (meson decisionD)
    

  qualified theorem rewrite_Goto_chain_safe:
    "rewrite_Goto_chain_safe Γ rs = Some rs'  Γ,γ,pg rs', s  t  Γ,γ,pg rs, s  t"
  proof(induction Γ rs arbitrary: rs' s rule: rewrite_Goto_chain_safe.induct)
  case 1 thus ?case by (simp split: option.split_asm if_split_asm)
  next
  case (2 Γ m chain rs) 
    from 2(2) obtain z x2 where "Γ chain = Some x2" and "terminal_chain x2"
            and "rs' = Rule m (Call chain) # z"
            and "Some z = rewrite_Goto_chain_safe Γ rs"
    by(auto split: option.split_asm if_split_asm)
    from 2(1) Γ chain = Some x2 ‹terminal_chain x2 ‹Some z = rewrite_Goto_chain_safe Γ rs 
      have IH: "Γ,γ,pg z, s  t = Γ,γ,pg rs, s  t" for s by simp

    have "Γ,γ,pg Rule m (Call chain) # z, Undecided  t  Γ,γ,pg Rule m (Goto chain) # rs, Undecided  t"
          (is "?lhs  ?rhs")
    proof(intro iffI)
      assume ?lhs
      with IH obtain ti where ti1: "Γ,γ,pg [Rule m (Call chain)], Undecided  ti" and ti2: "Γ,γ,pg rs, ti  t"
        by(auto elim: seqE_cons)
      show ?rhs
      proof(cases "matches γ m p")
      case False
        from replace_Goto_with_Call_in_terminal_chain Γ chain = Some x2 ‹terminal_chain x2 
        have " Γ,γ,pg [Rule m (Call chain)], Undecided  ti  Γ,γ,pg [Rule m (Goto chain)], Undecided  ti"
          by fast
        with False ti1 ti2 show ?thesis by(rule_tac t=ti in seq'_cons) simp+
      next
      case True
        from ti1 Γ chain = Some x2 ‹terminal_chain x2
        have g: "Γ,γ,pg [Rule m (Goto chain)], Undecided  ti"
          by(subst(asm) replace_Goto_with_Call_in_terminal_chain[symmetric]) simp+
        with True Γ chain = Some x2 ‹terminal_chain x2 obtain X where X: "ti = Decision X"
          by(blast dest: terminal_chain_Goto_decision)
        with this ti2 have "t = Decision X"
          by(simp add: decisionD)
        with g X True ti2 Γ chain = Some x2 ‹terminal_chain x2 show ?thesis
          apply(simp)
          apply(rule seq_cons_Goto_t, simp_all)
          done
      qed
    next
      assume ?rhs
      with IH Γ chain = Some x2 ‹terminal_chain x2 ‹Some z = rewrite_Goto_chain_safe Γ rs show ?lhs
        apply -
        apply(erule seqE_cons)
         subgoal for ti
         apply simp_all
         apply(rule_tac t=ti in seq'_cons)
           apply simp_all
         using replace_Goto_with_Call_in_terminal_chain by fast
        apply simp
        apply(frule(3) terminal_chain_Goto_decision)
        apply(subst(asm) replace_Goto_with_Call_in_terminal_chain, simp_all)
        apply(rule seq'_cons, simp_all)
        apply(elim exE)
        by (simp add: decision)
    qed
    with rs' = Rule m (Call chain) # z show ?case
      apply -
      apply(rule just_show_all_bigstep_semantics_equalities_with_start_Undecided)
      by simp

  qed(auto cong: step_IH_cong)
  


  text‹Example: The semantics are actually defined (for this example).›
  lemma defines "γ  (λ_ _. True)" and "m  MatchAny"
  shows "[''FORWARD''  [Rule m Log, Rule m (Call ''foo''), Rule m Drop],
          ''foo''  [Rule m Log, Rule m (Goto ''bar''), Rule m Reject],
          ''bar''  [Rule m (Goto ''baz''), Rule m Reject],
          ''baz''  [(Rule m Accept)]],
      γ,pg[Rule MatchAny (Call ''FORWARD'')], Undecided  (Decision FinalAllow)"
  apply(subgoal_tac "matches γ m p")
   prefer 2
   apply(simp add: γ_def m_def; fail)
  apply(rule call_result)
    apply(auto)
  apply(rule_tac t=Undecided in seq_cons)
    apply(auto intro: log)
  apply(rule_tac t="Decision FinalAllow" in seq_cons)
    apply(auto intro: decision)
  apply(rule call_result)
     apply(simp)+
  apply(rule_tac t=Undecided in seq_cons)
    apply(auto intro: log)
  apply(rule goto_decision)
    apply(simp)+
  apply(rule goto_decision)
    apply(simp)+
  apply(auto intro: accept)
  done


end


end

Theory Negation_Type_DNF

section‹Negation Type DNF›
theory Negation_Type_DNF
imports Negation_Type
begin


(*Just a draft. needed for packet_set*)

type_synonym 'a dnf = "(('a negation_type) list) list"

fun cnf_to_bool :: "('a  bool)  'a negation_type list  bool" where
  "cnf_to_bool _ []  True" |
  "cnf_to_bool f (Pos a#as)  (f a)  cnf_to_bool f as" |
  "cnf_to_bool f (Neg a#as)  (¬ f a)  cnf_to_bool f as"

fun dnf_to_bool :: "('a  bool)  'a dnf  bool" where
  "dnf_to_bool _ []  False" |
  "dnf_to_bool f (as#ass)  (cnf_to_bool f as)  (dnf_to_bool f ass)"

text‹representing @{const True}
definition dnf_True :: "'a dnf" where
  "dnf_True  [[]]"
lemma dnf_True: "dnf_to_bool f dnf_True"
  unfolding dnf_True_def by(simp)

text‹representing @{const False}
definition dnf_False :: "'a dnf" where
  "dnf_False  []"
lemma dnf_False: "¬ dnf_to_bool f dnf_False"
  unfolding dnf_False_def by(simp)

lemma cnf_to_bool_append: "cnf_to_bool γ (a1 @ a2)  cnf_to_bool γ a1  cnf_to_bool γ a2"
  by(induction γ a1 rule: cnf_to_bool.induct) (simp_all)
lemma dnf_to_bool_append: "dnf_to_bool γ (a1 @ a2)  dnf_to_bool γ a1  dnf_to_bool γ a2"
  by(induction a1) (simp_all)

definition dnf_and :: "'a dnf  'a dnf  'a dnf" where
  "dnf_and cnf1 cnf2 = [andlist1 @ andlist2. andlist1 <- cnf1, andlist2 <- cnf2]"

value "dnf_and ([[a,b], [c,d]]) ([[v,w], [x,y]])"

lemma cnf_to_bool_set: "cnf_to_bool f cnf  ( c  set cnf. (case c of Pos a  f a | Neg a  ¬ f a))"
  proof(induction cnf)
  case Nil thus ?case by simp
  next
  case Cons thus ?case by (simp split: negation_type.split)
  qed
lemma dnf_to_bool_set: "dnf_to_bool γ dnf  ( d  set dnf. cnf_to_bool γ d)"
  proof(induction dnf)
  case Nil thus ?case by simp
  next
  case (Cons d d1) thus ?case by(simp)
  qed

lemma dnf_to_bool_seteq: "set ` set d1 = set ` set d2  dnf_to_bool γ d1  dnf_to_bool γ d2"
  proof -
    assume assm: "set ` set d1 = set ` set d2"
    have helper1: "P d. (dset d. cset d. P c)  (dset ` set d. cd. P c)" by blast
    from assm show ?thesis
      apply(simp add: dnf_to_bool_set cnf_to_bool_set)
      apply(subst helper1)
      apply(subst helper1)
      apply(simp)
      done
  qed

lemma dnf_and_correct: "dnf_to_bool γ (dnf_and d1 d2)  dnf_to_bool γ d1  dnf_to_bool γ d2"
 apply(simp add: dnf_and_def)
 apply(induction d1)
  apply(simp)
 apply(simp add: dnf_to_bool_append)
 apply(simp add: dnf_to_bool_set cnf_to_bool_set)
 by (meson UnCI UnE)

lemma dnf_and_symmetric: "dnf_to_bool γ (dnf_and d1 d2)  dnf_to_bool γ (dnf_and d2 d1)"
  using dnf_and_correct by blast

 
subsubsection‹inverting a DNF›
  text‹Example›
  lemma "(¬ ((a1  a2)  b  c)) = ((¬a1  ¬ b  ¬ c)  (¬a2  ¬ b  ¬ c))" by blast
  lemma "(¬ ((a1  a2)  (b1  b2)  c)) = ((¬a1  ¬ b1  ¬ c)  (¬a2  ¬ b1  ¬ c)  (¬a1  ¬ b2  ¬ c)  (¬a2  ¬ b2  ¬ c))" by blast
  
  fun listprepend :: "'a list  'a list list  'a list list" where
    "listprepend [] ns = []" |
    "listprepend (a#as) ns = (map (λxs. a#xs) ns) @ (listprepend as ns)"
  
  lemma "listprepend [a,b] [as, bs] = [a#as, a#bs, b#as, b#bs]" by simp
  
  lemma map_a_and: "dnf_to_bool γ (map ((#) a) ds)  dnf_to_bool γ [[a]]  dnf_to_bool γ ds"
    apply(induction ds)
     apply(simp_all)
    apply(case_tac a)
     apply(simp_all)
     apply blast+
    done
  
  text‹this is how @{const listprepend} works:›
  lemma "¬ dnf_to_bool γ (listprepend [] ds)" by(simp)
  lemma "dnf_to_bool γ (listprepend [a] ds)  dnf_to_bool γ [[a]]  dnf_to_bool γ ds" by(simp add: map_a_and)
  lemma "dnf_to_bool γ (listprepend [a, b] ds)  (dnf_to_bool γ [[a]]  dnf_to_bool γ ds)  (dnf_to_bool γ [[b]]  dnf_to_bool γ ds)" 
    by(simp add: map_a_and dnf_to_bool_append)
  
  
  text‹We use ∃› to model the big ∨› operation›
  lemma listprepend_correct: "dnf_to_bool γ (listprepend as ds)  (a set as. dnf_to_bool γ [[a]]  dnf_to_bool γ ds)"
    apply(induction as)
     apply(simp)
    apply(simp)
    apply(rename_tac a as)
    apply(simp add: map_a_and cnf_to_bool_append dnf_to_bool_append)
    by blast
  lemma listprepend_correct': "dnf_to_bool γ (listprepend as ds)  (dnf_to_bool γ (map (λa. [a]) as)  dnf_to_bool γ ds)"
    apply(induction as)
     apply(simp)
    apply(simp)
    apply(rename_tac a as)
    apply(simp add: map_a_and cnf_to_bool_append dnf_to_bool_append)
    by blast
  
  lemma cnf_invert_singelton: "cnf_to_bool γ [invert a]  ¬ cnf_to_bool γ [a]" by(cases a, simp_all)
  
  lemma cnf_singleton_false: "(a'set as. ¬ cnf_to_bool γ [a'])  ¬ cnf_to_bool γ as"
    by(induction γ as rule: cnf_to_bool.induct) (simp_all)
  
  fun dnf_not :: "'a dnf  'a dnf" where
    "dnf_not [] = [[]]" | (*False goes to True*)
    "dnf_not (ns#nss) = listprepend (map invert ns) (dnf_not nss)"
  
  lemma dnf_not: "dnf_to_bool γ (dnf_not d)  ¬ dnf_to_bool γ d"
    apply(induction d)
     apply(simp_all)
    apply(simp add: listprepend_correct)
    apply(simp add: cnf_invert_singelton cnf_singleton_false)
    done

subsubsection‹Optimizing›
  (*there is probably a way better way to represent the set in the Collection framework
    A list of lists can be quite inefficient
    A better datastructure can help as we actually only use a set of sets*)
  definition optimize_dfn :: "'a dnf  'a dnf" where
    "optimize_dfn dnf = map remdups (remdups dnf)"

  lemma "dnf_to_bool f (optimize_dfn dnf) = dnf_to_bool f dnf"
    unfolding optimize_dfn_def
    apply(rule dnf_to_bool_seteq)
    apply(simp)
    by (metis image_cong image_image set_remdups)

end

Theory Matching_Embeddings

theory Matching_Embeddings
imports "Semantics_Ternary/Matching_Ternary" Matching "Semantics_Ternary/Unknown_Match_Tacs"
begin

section‹Boolean Matching vs. Ternary Matching›

term Semantics.matches
term Matching_Ternary.matches
(*'a is the primitive match condition, e.g. IpSrc …*)


text‹The two matching semantics are related. However, due to the ternary logic, we cannot directly translate one to the other.
The problem are @{const MatchNot} expressions which evaluate to @{const TernaryUnknown} because MatchNot TernaryUnknown› and
TernaryUnknown› are semantically equal!›
lemma "m β α a. Matching_Ternary.matches (β, α) m a p  
  Semantics.matches (λ atm p. case β atm p of TernaryTrue  True | TernaryFalse  False | TernaryUnknown  α a p) m p"
apply(rule_tac x="MatchNot (Match X)" in exI) ― ‹any @{term "X::'a"}
by (auto split: ternaryvalue.split ternaryvalue.split_asm simp add: matches_case_ternaryvalue_tuple)

text‹the @{const the} in the next definition is always defined›
lemma "m  {m. approx m p  TernaryUnknown}. ternary_to_bool (approx m p)  None"
  by(simp add: ternary_to_bool_None)


text‹
The Boolean and the ternary matcher agree (where the ternary matcher is defined)
›
definition matcher_agree_on_exact_matches :: "('a, 'p) matcher  ('a  'p  ternaryvalue)  bool" where
  "matcher_agree_on_exact_matches exact approx  p m. approx m p  TernaryUnknown  exact m p = the (ternary_to_bool (approx m p))"

text‹We say the Boolean and ternary matchers agree iff they return the same result or the ternary matcher returns @{const TernaryUnknown}.›
lemma "matcher_agree_on_exact_matches exact approx  (p m. exact m p = the (ternary_to_bool (approx m p))  approx m p = TernaryUnknown)"
  unfolding matcher_agree_on_exact_matches_def by blast
lemma matcher_agree_on_exact_matches_alt: (*no `the`*)
  "matcher_agree_on_exact_matches exact approx  (p m. approx m p  TernaryUnknown  bool_to_ternary (exact m p) = approx m p)"
  unfolding matcher_agree_on_exact_matches_def
  by (metis (full_types) bool_to_ternary.simps(1) bool_to_ternary.simps(2) option.sel ternary_to_bool.simps(1)
                         ternary_to_bool.simps(2) ternaryvalue.exhaust)

lemma eval_ternary_Not_TrueD: "eval_ternary_Not m = TernaryTrue  m = TernaryFalse"
  by (metis eval_ternary_Not.simps(1) eval_ternary_idempotence_Not)


lemma matches_comply_exact: "ternary_ternary_eval (map_match_tac β p m)  TernaryUnknown 
       matcher_agree_on_exact_matches γ β 
        Semantics.matches γ m p = Matching_Ternary.matches (β, α) m a p"
  proof(unfold matches_case_ternaryvalue_tuple,induction m)
  case Match thus ?case
       by(simp split: ternaryvalue.split add: matcher_agree_on_exact_matches_def)
  next
  case (MatchNot m) thus ?case
      apply(simp split: ternaryvalue.split add: matcher_agree_on_exact_matches_def)
      apply(case_tac "ternary_ternary_eval (map_match_tac β p m)")
        by(simp_all)
  next
  case (MatchAnd m1 m2)
    thus ?case
     apply(case_tac "ternary_ternary_eval (map_match_tac β p m1)")
       apply(case_tac [!] "ternary_ternary_eval (map_match_tac β p m2)")
                by(simp_all)
  next
  case MatchAny thus ?case by simp
  qed


lemma matcher_agree_on_exact_matches_gammaE:
  "matcher_agree_on_exact_matches γ β  β X p = TernaryTrue  γ X p"
  apply(simp add: matcher_agree_on_exact_matches_alt)
  apply(erule_tac x=p in allE)
  apply(erule_tac x=X in allE)
  apply(simp add: bool_to_ternary_simps)
  done




lemma in_doubt_allow_allows_Accept: "a = Accept  matcher_agree_on_exact_matches γ β 
        Semantics.matches γ m p  Matching_Ternary.matches (β, in_doubt_allow) m a p"
  apply(case_tac "ternary_ternary_eval (map_match_tac β p m)  TernaryUnknown")
   using matches_comply_exact apply fast
  apply(simp add: matches_case_ternaryvalue_tuple)
  done

lemma not_exact_match_in_doubt_allow_approx_match: "matcher_agree_on_exact_matches γ β  a = Accept  a = Reject  a = Drop 
  ¬ Semantics.matches γ m p  
  (a = Accept  Matching_Ternary.matches (β, in_doubt_allow) m a p)  ¬ Matching_Ternary.matches (β, in_doubt_allow) m a p"
  apply(case_tac "ternary_ternary_eval (map_match_tac β p m)  TernaryUnknown")
   apply(drule(1) matches_comply_exact[where α=in_doubt_allow and a=a])
   apply(rule disjI2)
   apply fast
  apply(simp)
  apply(clarify)
  apply(simp add: matches_case_ternaryvalue_tuple)
  apply(cases a)
         apply(simp_all)
  done




lemma in_doubt_deny_denies_DropReject: "a = Drop  a = Reject  matcher_agree_on_exact_matches γ β 
        Semantics.matches γ m p  Matching_Ternary.matches (β, in_doubt_deny) m a p"
  apply(case_tac "ternary_ternary_eval (map_match_tac β p m)  TernaryUnknown")
   using matches_comply_exact apply fast
   apply(simp)
  apply(auto simp add: matches_case_ternaryvalue_tuple)
  done

lemma not_exact_match_in_doubt_deny_approx_match: "matcher_agree_on_exact_matches γ β  a = Accept  a = Reject  a = Drop 
  ¬ Semantics.matches γ m p  
  ((a = Drop  a = Reject)  Matching_Ternary.matches (β, in_doubt_deny) m a p)  ¬ Matching_Ternary.matches (β, in_doubt_deny) m a p"
  apply(case_tac "ternary_ternary_eval (map_match_tac β p m)  TernaryUnknown")
   apply(drule(1) matches_comply_exact[where α=in_doubt_deny and a=a])
   apply(rule disjI2)
   apply fast
  apply(simp)
  apply(clarify)
  apply(simp add: matches_case_ternaryvalue_tuple)
  apply(cases a)
         apply(simp_all)
  done

text‹The ternary primitive matcher can return exactly the result of the Boolean primitive matcher›
definition βmagic :: "('a, 'p) matcher  ('a  'p  ternaryvalue)" where
  "βmagic γ  (λ a p. if γ a p then TernaryTrue else TernaryFalse)"

lemma "matcher_agree_on_exact_matches γ (βmagic γ)"
  by(simp add: matcher_agree_on_exact_matches_def βmagic_def)

lemma βmagic_not_Unknown: "ternary_ternary_eval (map_match_tac (βmagic γ) p m)  TernaryUnknown"
  proof(induction m)
  case MatchNot thus ?case using eval_ternary_Not_UnknownD βmagic_def
     by (simp) blast
  case (MatchAnd m1 m2) thus ?case
    apply(case_tac "ternary_ternary_eval (map_match_tac (βmagic γ) p m1)")
      apply(case_tac [!] "ternary_ternary_eval (map_match_tac (βmagic γ) p m2)")
            by(simp_all add: βmagic_def)
  qed (simp_all add: βmagic_def)

lemma βmagic_matching: "Matching_Ternary.matches ((βmagic γ), α) m a p  Semantics.matches γ m p"
  proof(induction m)
  case Match thus ?case 
    by(simp add: βmagic_def matches_case_ternaryvalue_tuple)
  case MatchNot thus ?case
    by(simp add: matches_case_ternaryvalue_tuple βmagic_not_Unknown split: ternaryvalue.split_asm)
  qed (simp_all add: matches_case_ternaryvalue_tuple split: ternaryvalue.split ternaryvalue.split_asm)
  


end

Theory Fixed_Action

theory Fixed_Action
imports Semantics_Ternary
begin

section‹Fixed Action›

text‹If firewall rules have the same action, we can focus on the matching only.›

text‹Applying a rule once or several times makes no difference.›
lemma approximating_bigstep_fun_prepend_replicate: 
  "n > 0  approximating_bigstep_fun γ p (r#rs) Undecided = approximating_bigstep_fun γ p ((replicate n r)@rs) Undecided"
apply(induction n)
 apply(simp)
apply(simp)
apply(case_tac r)
apply(rename_tac m a)
apply(simp split: action.split)
by fastforce




text‹utility lemmas›
context
begin
  private lemma fixedaction_Log: "approximating_bigstep_fun γ p (map (λm. Rule m Log) ms) Undecided = Undecided"
    by(induction ms, simp_all)

  private lemma fixedaction_Empty:"approximating_bigstep_fun γ p (map (λm. Rule m Empty) ms) Undecided = Undecided"
    by(induction ms, simp_all)

  private lemma helperX1_Log: "matches γ m' Log p  
         approximating_bigstep_fun γ p (map ((λm. Rule m Log)  MatchAnd m') m2' @ rs2) Undecided =
         approximating_bigstep_fun γ p rs2 Undecided"
    by(induction m2')(simp_all split: action.split)

  private lemma helperX1_Empty: "matches γ m' Empty p  
         approximating_bigstep_fun γ p (map ((λm. Rule m Empty)  MatchAnd m') m2' @ rs2) Undecided =
         approximating_bigstep_fun γ p rs2 Undecided"
    by(induction m2')(simp_all split: action.split)

  private lemma helperX3: "matches γ m' a p 
       approximating_bigstep_fun γ p (map ((λm. Rule m a)  MatchAnd m') m2' @ rs2 ) Undecided =
       approximating_bigstep_fun γ p (map (λm. Rule m a) m2' @ rs2) Undecided"
  proof(induction m2')
    case Nil thus ?case by simp
    next
    case Cons thus ?case by(cases a) (simp_all add: matches_simps)
  qed
  
  lemmas fixed_action_simps = fixedaction_Log fixedaction_Empty helperX1_Log helperX1_Empty helperX3
end

lemma fixedaction_swap:
   "approximating_bigstep_fun γ p (map (λm. Rule m a) (m1@m2)) s = approximating_bigstep_fun γ p (map (λm. Rule m a) (m2@m1)) s"
proof(induction s rule: just_show_all_approximating_bigstep_fun_equalities_with_start_Undecided)
case Undecided
  have "approximating_bigstep_fun γ p (map (λm. Rule m a) m1 @ map (λm. Rule m a) m2) Undecided =
        approximating_bigstep_fun γ p (map (λm. Rule m a) m2 @ map (λm. Rule m a) m1) Undecided"
  proof(induction m1)
    case Nil thus ?case by simp
    next
    case (Cons m m1)
      { fix m rs
        have "approximating_bigstep_fun γ p ((map (λm. Rule m Log) m)@rs) Undecided =
            approximating_bigstep_fun γ p rs Undecided"
        by(induction m) (simp_all)
      } note Log_helper=this
      { fix m rs
        have "approximating_bigstep_fun γ p ((map (λm. Rule m Empty) m)@rs) Undecided =
            approximating_bigstep_fun γ p rs Undecided"
        by(induction m) (simp_all)
      } note Empty_helper=this
      
      show ?case
        proof(cases "matches γ m a p")
          case True
            thus ?thesis
              proof(induction m2)
                case Nil thus ?case by simp
              next
                case Cons thus ?case
                  apply(simp split:action.split action.split_asm)
                  using Log_helper Empty_helper by fastforce+ 
              qed
          next
          case False
            thus ?thesis
             apply(simp)
             apply(simp add: Cons.IH)
             apply(induction m2)
              apply(simp_all)
             apply(simp split:action.split action.split_asm)
             apply fastforce
            done
        qed
    qed
  thus ?thesis using Undecided by simp
qed

corollary fixedaction_reorder: "approximating_bigstep_fun γ p (map (λm. Rule m a) (m1 @ m2 @ m3)) s = approximating_bigstep_fun γ p (map (λm. Rule m a) (m2 @ m1 @ m3)) s"
proof(induction s rule: just_show_all_approximating_bigstep_fun_equalities_with_start_Undecided)
case Undecided
have "approximating_bigstep_fun γ p (map (λm. Rule m a) (m1 @ m2 @ m3)) Undecided = approximating_bigstep_fun γ p (map (λm. Rule m a) (m2 @ m1 @ m3)) Undecided"
  proof(induction m3)
    case Nil thus ?case using fixedaction_swap by fastforce
    next
    case (Cons m3'1 m3)
      have "approximating_bigstep_fun γ p (map (λm. Rule m a) ((m3'1 # m3) @ m1 @ m2)) Undecided = approximating_bigstep_fun γ p (map (λm. Rule m a) ((m3'1 # m3) @ m2 @ m1)) Undecided"
        apply(simp)
        apply(cases "matches γ m3'1 a p")
         apply(simp split: action.split action.split_asm)
         apply (metis append_assoc fixedaction_swap map_append Cons.IH)
        apply(simp)
        by (metis append_assoc fixedaction_swap map_append Cons.IH)
      hence "approximating_bigstep_fun γ p (map (λm. Rule m a) ((m1 @ m2) @ m3'1 # m3)) Undecided = approximating_bigstep_fun γ p (map (λm. Rule m a) ((m2 @ m1) @ m3'1 # m3)) Undecided"
        apply(subst fixedaction_swap)
        apply(subst(2) fixedaction_swap)
        by simp
      thus ?case
        apply(subst append_assoc[symmetric])
        apply(subst append_assoc[symmetric])
        by simp
  qed
  thus ?thesis using Undecided by simp
qed


text‹If the actions are equal, the @{term set} (position and replication independent) of the match expressions can be considered.›
lemma approximating_bigstep_fun_fixaction_matchseteq: "set m1 = set m2 
        approximating_bigstep_fun γ p (map (λm. Rule m a) m1) s = 
       approximating_bigstep_fun γ p (map (λm. Rule m a) m2) s"
proof(rule just_show_all_approximating_bigstep_fun_equalities_with_start_Undecided)
  assume m1m2_seteq: "set m1 = set m2" and "s = Undecided"
  from m1m2_seteq have
    "approximating_bigstep_fun γ p (map (λm. Rule m a) m1) Undecided =
     approximating_bigstep_fun γ p (map (λm. Rule m a) m2) Undecided"
  proof(induction m1 arbitrary: m2)
   case Nil thus ?case by simp
   next
   case (Cons m m1)
    show ?case
      proof (cases "m  set m1")
      case True
        from True have "set m1 = set (m # m1)" by auto
        from Cons.IH[OF ‹set m1 = set (m # m1)] have "approximating_bigstep_fun γ p (map (λm. Rule m a) (m # m1)) Undecided = approximating_bigstep_fun γ p (map (λm. Rule m a) (m1)) Undecided" ..
        thus ?thesis by (metis Cons.IH Cons.prems ‹set m1 = set (m # m1))
      next
      case False
        from False have "m  set m1" .
        show ?thesis
        proof (cases "m  set m2")
          case True
          from True m  set m1 Cons.prems have "set m1 = set m2" by auto
          from Cons.IH[OF this] show ?thesis by (metis Cons.IH Cons.prems ‹set m1 = set m2)
        next
        case False
          hence "m  set m2" by simp
  
          have repl_filter_simp: "(replicate (length [xm2 . x = m]) m) = [xm2 . x = m]"
            by (metis (lifting, full_types) filter_set member_filter replicate_length_same)
  
          from Cons.prems  m  set m1 have "set m1 = set (filter (λx. xm) m2)" by auto
          from Cons.IH[OF this] have "approximating_bigstep_fun γ p (map (λm. Rule m a) m1) Undecided = approximating_bigstep_fun γ p (map (λm. Rule m a) [xm2 . x  m]) Undecided" .
          from this have "approximating_bigstep_fun γ p (map (λm. Rule m a) (m#m1)) Undecided = approximating_bigstep_fun γ p (map (λm. Rule m a) (m#[xm2 . x  m])) Undecided"
            apply(simp split: action.split)
            by fast
          also have " = approximating_bigstep_fun γ p (map (λm. Rule m a) ([xm2 . x = m]@[xm2 . x  m])) Undecided"
            apply(simp only: list.map)
            thm approximating_bigstep_fun_prepend_replicate[where n="length [xm2 . x = m]"]
            apply(subst approximating_bigstep_fun_prepend_replicate[where n="length [xm2 . x = m]"])
            apply (metis (full_types) False filter_empty_conv neq0_conv repl_filter_simp replicate_0)
            by (metis (lifting, no_types) map_append map_replicate repl_filter_simp)
          also have " =  approximating_bigstep_fun γ p (map (λm. Rule m a) m2) Undecided"
            proof(induction m2)
            case Nil thus ?case by simp
            next
            case(Cons m2'1 m2')
              have "approximating_bigstep_fun γ p (map (λm. Rule m a) [xm2' . x = m] @ Rule m2'1 a # map (λm. Rule m a) [xm2' . x  m]) Undecided =
                    approximating_bigstep_fun γ p (map (λm. Rule m a) ([xm2' . x = m] @ [m2'1] @ [xm2' . x  m])) Undecided" by fastforce
              also have " = approximating_bigstep_fun γ p (map (λm. Rule m a) ([m2'1] @ [xm2' . x = m] @ [xm2' . x  m])) Undecided"
              using fixedaction_reorder by fast 
              finally have XX: "approximating_bigstep_fun γ p (map (λm. Rule m a) [xm2' . x = m] @ Rule m2'1 a # map (λm. Rule m a) [xm2' . x  m]) Undecided =
                    approximating_bigstep_fun γ p (Rule m2'1 a # (map (λm. Rule m a) [xm2' . x = m] @ map (λm. Rule m a) [xm2' . x  m])) Undecided"
              by fastforce
              from Cons show ?case
                apply(case_tac "m2'1 = m")
                 apply(simp split: action.split)
                 apply fast
                apply(simp del: approximating_bigstep_fun.simps)
                apply(simp only: XX)
                apply(case_tac "matches γ m2'1 a p")
                 apply(simp)
                 apply(simp split: action.split)
                 apply(fast)
                apply(simp)
                done
            qed
          finally show ?thesis .
        qed
      qed
  qed
  thus ?thesis using s = Undecided› by simp
qed



subsection@{term match_list}
  text‹Reducing the firewall semantics to short-circuit matching evaluation›

  fun match_list :: "('a, 'packet) match_tac  'a match_expr list  action  'packet  bool" where
   "match_list γ [] a p = False" |
   "match_list γ (m#ms) a p = (if matches γ m a p then True else match_list γ ms a p)"


  lemma match_list_matches: "match_list γ ms a p  (m  set ms. matches γ m a p)"
    by(induction ms, simp_all)

  lemma match_list_True: "match_list γ ms a p  approximating_bigstep_fun γ p (map (λm. Rule m a) ms) Undecided = (case a of Accept  Decision FinalAllow
              | Drop  Decision FinalDeny
              | Reject  Decision FinalDeny
              | Log  Undecided
              | Empty  Undecided
              ― ‹unhandled cases›
              )"
    apply(induction ms)
     apply(simp)
    apply(simp split: if_split_asm action.split)
    apply(simp add: fixed_action_simps)
    done
  lemma match_list_False: "¬ match_list γ ms a p  approximating_bigstep_fun γ p (map (λm. Rule m a) ms) Undecided = Undecided"
    apply(induction ms)
     apply(simp)
    apply(simp split: if_split_asm action.split)
    done

  text‹The key idea behind @{const match_list}: Reducing semantics to match list›
  lemma match_list_semantics: "match_list γ ms1 a p  match_list γ ms2 a p 
    approximating_bigstep_fun γ p (map (λm. Rule m a) ms1) s = approximating_bigstep_fun γ p (map (λm. Rule m a) ms2) s"
    apply(rule just_show_all_approximating_bigstep_fun_equalities_with_start_Undecided)
    apply(simp)
    apply(thin_tac "s = Undecided")
    apply(induction ms2)
     apply(simp)
     apply(induction ms1)
      apply(simp)
     apply(simp split: if_split_asm)
    apply(rename_tac m ms2)
    apply(simp del: approximating_bigstep_fun.simps)
    apply(simp split: if_split_asm del: approximating_bigstep_fun.simps)
     apply(simp split: action.split add: match_list_True fixed_action_simps)
    apply(simp)
    done


  text‹We can exploit de-morgan to get a disjunction in the match expression!›
  (*but we need to normalize afterwards, which is quite slow*)
  fun match_list_to_match_expr :: "'a match_expr list  'a match_expr" where
    "match_list_to_match_expr [] = MatchNot MatchAny" |
    "match_list_to_match_expr (m#ms) = MatchOr m (match_list_to_match_expr ms)"
  text@{const match_list_to_match_expr} constructs a unwieldy @{typ "'a match_expr"} from a list.
        The semantics of the resulting match expression is the disjunction of the elements of the list.
        This is handy because the normal match expressions do not directly support disjunction.
        Use this function with care because the resulting match expression is very ugly!›
  lemma match_list_to_match_expr_disjunction: "match_list γ ms a p  matches γ (match_list_to_match_expr ms) a p"
    apply(induction ms rule: match_list_to_match_expr.induct)
     apply(simp add: bunch_of_lemmata_about_matches; fail)
    apply(simp add: MatchOr)
  done

  lemma match_list_singleton: "match_list γ [m] a p  matches γ m a p" by(simp)

  lemma match_list_append: "match_list γ (m1@m2) a p  (¬ match_list γ m1 a p  match_list γ m2 a p)"
      by(induction m1) simp+

  lemma match_list_helper1: "¬ matches γ m2 a p  match_list γ (map (λx. MatchAnd x m2) m1') a p  False"
    apply(induction m1')
     apply(simp; fail)
    apply(simp split:if_split_asm)
    by(auto dest: matches_dest)
  lemma match_list_helper2: " ¬ matches γ m a p  ¬ match_list γ (map (MatchAnd m) m2') a p"
    apply(induction m2')
     apply(simp; fail)
    apply(simp split:if_split_asm)
    by(auto dest: matches_dest)
  lemma match_list_helper3: "matches γ m a p  match_list γ m2' a p  match_list γ (map (MatchAnd m) m2') a p"
    apply(induction m2')
     apply(simp; fail)
    apply(simp split:if_split_asm)
    by (simp add: matches_simps)
  lemma match_list_helper4: "¬ match_list γ m2' a p  ¬ match_list γ (map (MatchAnd aa) m2') a p "
    apply(induction m2')
     apply(simp; fail)
    apply(simp split:if_split_asm)
    by(auto dest: matches_dest)
  lemma match_list_helper5: " ¬ match_list γ m2' a p  ¬ match_list γ (concat (map (λx. map (MatchAnd x) m2') m1')) a p "
    apply(induction m2')
     apply(simp add:empty_concat; fail)
    apply(simp split:if_split_asm)
    apply(induction m1')
     apply(simp; fail)
    apply(simp add: match_list_append)
    by(auto dest: matches_dest)
  lemma match_list_helper6: "¬ match_list γ m1' a p  ¬ match_list γ (concat (map (λx. map (MatchAnd x) m2') m1')) a p "
    apply(induction m2')
     apply(simp add:empty_concat; fail)
    apply(simp split:if_split_asm)
    apply(induction m1')
     apply(simp; fail)
    apply(simp add: match_list_append split: if_split_asm)
    by(auto dest: matches_dest)
  
  lemmas match_list_helper = match_list_helper1 match_list_helper2 match_list_helper3 match_list_helper4 match_list_helper5 match_list_helper6
  hide_fact match_list_helper1 match_list_helper2 match_list_helper3 match_list_helper4 match_list_helper5 match_list_helper6

  lemma match_list_map_And1: "matches γ m1 a p = match_list γ m1' a p 
           matches γ (MatchAnd m1 m2) a p  match_list γ  (map (λx. MatchAnd x m2) m1') a p"
    apply(induction m1')
     apply(auto dest: matches_dest; fail)[1]
    apply(simp split: if_split_asm)
     apply safe
        apply(simp_all add: matches_simps)
      apply(auto dest: match_list_helper(1))[1]
     by(auto dest: matches_dest)

  lemma matches_list_And_concat: "matches γ m1 a p = match_list γ m1' a p  matches γ m2 a p = match_list γ m2' a p 
           matches γ (MatchAnd m1 m2) a p  match_list γ [MatchAnd x y. x <- m1', y <- m2'] a p"
    apply(induction m1')
     apply(auto dest: matches_dest; fail)[1]
    apply(simp split: if_split_asm)
     prefer 2
     apply(simp add: match_list_append)
     apply(subgoal_tac "¬ match_list γ (map (MatchAnd aa) m2') a p")
      apply(simp; fail)
     apply safe
               apply(simp_all add: matches_simps match_list_append match_list_helper)
    done

  lemma match_list_concat: "match_list γ (concat lss) a p  (ls  set lss. match_list γ ls a p)"
    apply(induction lss)
     apply(simp; fail)
    by(auto simp add: match_list_append)
    

lemma fixedaction_wf_ruleset: "wf_ruleset γ p (map (λm. Rule m a) ms) 
  ¬ match_list γ ms a p  ¬ (chain. a = Call chain)  a  Return  ¬ (chain. a = Goto chain)  a  Unknown"
  proof -
  have helper: "a b c. a  c  (a  b) = (c  b)" by fast
  show ?thesis
    apply(simp add: wf_ruleset_def)
    apply(rule helper)
    apply(induction ms)
     apply(simp; fail)
    apply(simp)
    done
  qed

lemma wf_ruleset_singleton: "wf_ruleset γ p [Rule m a]  ¬ matches γ m a p  ¬ (chain. a = Call chain)  a  Return  ¬ (chain. a = Goto chain)  a  Unknown"
  by(simp add: wf_ruleset_def)




end

Theory Normalized_Matches

theory Normalized_Matches
imports Fixed_Action
begin

section‹Normalized (DNF) matches›

text‹simplify a match expression. The output is a list of match exprissions, the semantics is ∨› of the list elements.›
fun normalize_match :: "'a match_expr  'a match_expr list" where
  "normalize_match (MatchAny) = [MatchAny]" |
  "normalize_match (Match m) = [Match m]" |
  "normalize_match (MatchAnd m1 m2) = [MatchAnd x y. x <- normalize_match m1, y <- normalize_match m2]" |
  "normalize_match (MatchNot (MatchAnd m1 m2)) = normalize_match (MatchNot m1) @ normalize_match (MatchNot m2)" | (*DeMorgan*)
  "normalize_match (MatchNot (MatchNot m)) = normalize_match m" | (*idem*)
  "normalize_match (MatchNot (MatchAny)) = []" | (*false*)
  "normalize_match (MatchNot (Match m)) = [MatchNot (Match m)]"


lemma normalize_match_not_matcheq_matchNone: "m'  set (normalize_match m). ¬ matcheq_matchNone m'"
  proof(induction m rule: normalize_match.induct)
  case 4 thus ?case by (simp) blast
  qed(simp_all)
 
lemma normalize_match_empty_iff_matcheq_matchNone: "normalize_match m = []  matcheq_matchNone m "
  proof(induction m rule: normalize_match.induct) 
  case 3 thus ?case  by (simp) fastforce
  qed(simp_all)

lemma match_list_normalize_match: "match_list γ [m] a p  match_list γ (normalize_match m) a p"
  proof(induction m rule:normalize_match.induct)
  case 1 thus ?case by(simp add: match_list_singleton)
  next
  case 2 thus ?case by(simp add: match_list_singleton)
  next
  case (3 m1 m2) thus ?case 
    apply(simp_all add: match_list_singleton del: match_list.simps(2))
    apply(case_tac "matches γ m1 a p")
     apply(rule matches_list_And_concat)
      apply(simp)
     apply(case_tac "(normalize_match m1)")
      apply simp
     apply (auto)[1]
    apply(simp add: bunch_of_lemmata_about_matches match_list_helper)
    done
  next
  case 4 thus ?case 
    apply(simp_all add: match_list_singleton del: match_list.simps(2))
    apply(simp add: match_list_append)
    apply(safe)
        apply(simp_all add: matches_DeMorgan)
    done
  next 
  case 5 thus ?case 
    by(simp add: match_list_singleton bunch_of_lemmata_about_matches)
  next
  case 6 thus ?case 
    by(simp add: match_list_singleton bunch_of_lemmata_about_matches)
  next
  case 7 thus ?case by(simp add: match_list_singleton)
qed
  
thm match_list_normalize_match[simplified match_list_singleton]


theorem normalize_match_correct: "approximating_bigstep_fun γ p (map (λm. Rule m a) (normalize_match m)) s = approximating_bigstep_fun γ p [Rule m a] s"
apply(rule match_list_semantics[of _ _ _ _ "[m]", simplified])
using match_list_normalize_match by fastforce


lemma normalize_match_empty: "normalize_match m = []  ¬ matches γ m a p"
  proof(induction m rule: normalize_match.induct)
  case 3 thus ?case by(fastforce dest: matches_dest)
  next
  case 4 thus ?case using match_list_normalize_match by (simp add: matches_DeMorgan)
  next
  case 5 thus ?case using matches_not_idem by fastforce
  next
  case 6 thus ?case by(simp add: bunch_of_lemmata_about_matches)
  qed(simp_all)


lemma matches_to_match_list_normalize: "matches γ m a p = match_list γ (normalize_match m) a p"
  using match_list_normalize_match[simplified match_list_singleton] .

lemma wf_ruleset_normalize_match: "wf_ruleset γ p [(Rule m a)]  wf_ruleset γ p (map (λm. Rule m a) (normalize_match m))"
proof(induction m rule: normalize_match.induct)
  case 1 thus ?case by simp
  next
  case 2 thus ?case by simp
  next
  case 3 thus ?case by(simp add: fixedaction_wf_ruleset wf_ruleset_singleton matches_to_match_list_normalize)
  next
  case 4 thus ?case 
    apply(simp add: wf_ruleset_append)
    apply(simp add: fixedaction_wf_ruleset)
    apply(unfold wf_ruleset_singleton)
    apply(safe) (*there is a simpler way but the simplifier takes for ever if we just apply it here, ...*)
           apply(simp_all add: matches_to_match_list_normalize)
         apply(simp_all add: match_list_append)
    done
  next
  case 5 thus ?case by(simp add: wf_ruleset_singleton matches_to_match_list_normalize)
  next
  case 6 thus ?case by(simp add: wf_ruleset_def)
  next
  case 7 thus ?case by(simp_all add: wf_ruleset_append)
  qed


lemma normalize_match_wf_ruleset: "wf_ruleset γ p (map (λm. Rule m a) (normalize_match m))  wf_ruleset γ p [Rule m a]"
proof(induction m rule: normalize_match.induct)
  case 1 thus ?case by simp
  next
  case 2 thus ?case by simp
  next
  case 3 thus ?case by(simp add: fixedaction_wf_ruleset wf_ruleset_singleton matches_to_match_list_normalize)
  next
  case 4 thus ?case 
    apply(simp add: wf_ruleset_append)
    apply(simp add: fixedaction_wf_ruleset)
    apply(unfold wf_ruleset_singleton)
    apply(safe)
         apply(simp_all add: matches_to_match_list_normalize)
         apply(simp_all add: match_list_append)
    done
  next
  case 5 thus ?case 
    unfolding wf_ruleset_singleton by(simp add: matches_to_match_list_normalize)
  next
  case 6 thus ?case unfolding wf_ruleset_singleton by(simp add: bunch_of_lemmata_about_matches)
  next
  case 7 thus ?case by(simp add: wf_ruleset_append)
  qed


lemma good_ruleset_normalize_match: "good_ruleset [(Rule m a)]  good_ruleset (map (λm. Rule m a) (normalize_match m))"
by(simp add: good_ruleset_def)

section‹Normalizing rules instead of only match expressions›
  fun normalize_rules :: "('a match_expr  'a match_expr list)  'a rule list  'a rule list" where
    "normalize_rules _ [] = []" |
    "normalize_rules f ((Rule m a)#rs) = (map (λm. Rule m a) (f m))@(normalize_rules f rs)"
  
  lemma normalize_rules_singleton: "normalize_rules f [Rule m a] = map (λm. Rule m a) (f m)" by(simp)
  lemma normalize_rules_fst: "(normalize_rules f (r # rs)) = (normalize_rules f [r]) @ (normalize_rules f rs)"
    by(cases r) (simp)

  lemma normalize_rules_concat_map:
    "normalize_rules f rs = concat (map (λr. map (λm. Rule m (get_action r)) (f (get_match r))) rs)"
    apply(induction rs)
     apply(simp_all)
    apply(rename_tac r rs, case_tac r)
    apply(simp)
    done

  lemma good_ruleset_normalize_rules: "good_ruleset rs  good_ruleset (normalize_rules f rs)"
    proof(induction rs)
    case Nil thus ?case by (simp)
    next
    case(Cons r rs)
      from Cons have IH: "good_ruleset (normalize_rules f rs)" using good_ruleset_tail by blast
      from Cons.prems have "good_ruleset [r]" using good_ruleset_fst by fast
      hence "good_ruleset (normalize_rules f [r])" by(cases r) (simp add: good_ruleset_alt)
      with IH good_ruleset_append have "good_ruleset (normalize_rules f [r] @ normalize_rules f rs)" by blast
      thus ?case using normalize_rules_fst by metis
    qed

  lemma simple_ruleset_normalize_rules: "simple_ruleset rs  simple_ruleset (normalize_rules f rs)"
    proof(induction rs)
    case Nil thus ?case by (simp)
    next
    case(Cons r rs)
      from Cons have IH: "simple_ruleset (normalize_rules f rs)" using simple_ruleset_tail by blast
      from Cons.prems have "simple_ruleset [r]" using simple_ruleset_append by fastforce
      hence "simple_ruleset (normalize_rules f [r])" by(cases r) (simp add: simple_ruleset_def) 
      with IH simple_ruleset_append have  "simple_ruleset (normalize_rules f [r] @ normalize_rules f rs)" by blast
      thus ?case using normalize_rules_fst by metis
    qed
    

  (*tuned version of the next lemma for usage with normalize_primitive_extract where P=normalized_nnf_match*)
  lemma normalize_rules_match_list_semantics_3: 
    assumes "m a. P m  match_list γ (f m) a p = matches γ m a p"
    and "simple_ruleset rs"
    and P: " r  set rs. P (get_match r)"
    shows "approximating_bigstep_fun γ p (normalize_rules f rs) s = approximating_bigstep_fun γ p rs s"
    proof -
      have assm_1: "rset rs. match_list γ (f (get_match r)) (get_action r) p = matches γ (get_match r) (get_action r) p" using P assms(1) by blast
      { fix r s
        assume "r  set rs"
        with assm_1 have "match_list γ (f (get_match r)) (get_action r) p  match_list γ [(get_match r)] (get_action r) p" by simp
        with match_list_semantics[of γ "f (get_match r)" "(get_action r)" p "[(get_match r)]"] have
          "approximating_bigstep_fun γ p (map (λm. Rule m (get_action r)) (f (get_match r))) s = 
           approximating_bigstep_fun γ p [Rule (get_match r) (get_action r)] s" by simp
        hence "(approximating_bigstep_fun γ p (normalize_rules f [r]) s) = approximating_bigstep_fun γ p [r] s"
          by(cases r) (simp)
      }
  
    with assms show ?thesis
      proof(induction rs arbitrary: s)
        case Nil thus ?case by (simp)
      next
        case (Cons r rs)
        from Cons.prems have "simple_ruleset [r]" by(simp add: simple_ruleset_def)
        with simple_imp_good_ruleset good_imp_wf_ruleset have wf_r: "wf_ruleset γ p [r]" by fast
  
        from ‹simple_ruleset [r] simple_imp_good_ruleset good_imp_wf_ruleset have wf_r: 
          "wf_ruleset γ p [r]" by fast
        from simple_ruleset_normalize_rules[OF ‹simple_ruleset [r]] have "simple_ruleset (normalize_rules f [r])"
          by(simp) 
        with simple_imp_good_ruleset good_imp_wf_ruleset have wf_nr: "wf_ruleset γ p (normalize_rules f [r])" by fast
  
        from Cons have IH: "s. approximating_bigstep_fun γ p (normalize_rules f rs) s = approximating_bigstep_fun γ p rs s"
          using simple_ruleset_tail by force
        
        from Cons have a: "s. approximating_bigstep_fun γ p (normalize_rules f [r]) s = approximating_bigstep_fun γ p [r] s" by simp

        show ?case
          apply(subst normalize_rules_fst)
          apply(simp add: approximating_bigstep_fun_seq_wf[OF wf_nr])
          apply(subst approximating_bigstep_fun_seq_wf[OF wf_r, simplified])
          apply(simp add: a)
          apply(simp add: IH)  
          done
      qed
    qed

 corollary normalize_rules_match_list_semantics: 
  "(m a. match_list γ (f m) a p = matches γ m a p)  simple_ruleset rs 
   approximating_bigstep_fun γ p (normalize_rules f rs) s = approximating_bigstep_fun γ p rs s"
  by(rule normalize_rules_match_list_semantics_3[where P="λ_. True"]) simp_all

lemma in_normalized_matches: "ls  set (normalize_match m)  matches γ ls a p  matches γ m a p"
  by (meson match_list_matches matches_to_match_list_normalize)

 text‹applying a function (with a prerequisite Q›) to all rules›
 lemma normalize_rules_property:
 assumes " r  set rs. P (get_match r)"
     and "m. P m  (m'  set (f m). Q m')"
  shows "r  set (normalize_rules f rs). Q (get_match r)"
  proof
    fix r' assume a: "r'  set (normalize_rules f rs)"
    from a assms show "Q (get_match r')"
    proof(induction rs)
    case Nil thus ?case by simp
    next
    case (Cons r rs)
      { 
        assume "r'  set (normalize_rules f rs)"
        from Cons.IH this have "Q (get_match r')" using Cons.prems(2) Cons.prems(3) by fastforce
      } note 1=this
      { 
        assume "r'  set (normalize_rules f [r])"
        hence a: "(get_match r')  set (f (get_match r))" by(cases r) (auto)
        with Cons.prems(2) Cons.prems(3) have "m'set (f (get_match r)). Q m'" by auto
        with a have "Q (get_match r')" by blast
      } note 2=this
      from Cons.prems(1) have "r'  set (normalize_rules f [r])  r'  set (normalize_rules f rs)"
        by(subst(asm) normalize_rules_fst) auto
      with 1 2 show ?case
        by(elim disjE)(simp)
    qed
 qed

 text‹If a function f› preserves some property of the match expressions, then this property is preserved when applying @{const normalize_rules}

 lemma normalize_rules_preserves: assumes " r  set rs. P (get_match r)"
     and "m. P m  (m'  set (f m). P m')"
  shows "r  set (normalize_rules f rs). P (get_match r)"
  using normalize_rules_property[OF assms(1) assms(2)] by simp

fun normalize_rules_dnf :: "'a rule list  'a rule list" where
  "normalize_rules_dnf [] = []" |
  "normalize_rules_dnf ((Rule m a)#rs) = (map (λm. Rule m a) (normalize_match m))@(normalize_rules_dnf rs)"

lemma normalize_rules_dnf_append: "normalize_rules_dnf (rs1@rs2) = normalize_rules_dnf rs1 @ normalize_rules_dnf rs2"
  proof(induction rs1 rule: normalize_rules_dnf.induct)
  qed(simp_all)

lemma normalize_rules_dnf_def2: "normalize_rules_dnf = normalize_rules normalize_match"
  proof(simp add: fun_eq_iff, intro allI)
    fix x::"'a rule list" show "normalize_rules_dnf x = normalize_rules normalize_match x"
    proof(induction x)
    case (Cons r rs) thus ?case by (cases r) simp
    qed(simp)
  qed

lemma wf_ruleset_normalize_rules_dnf: "wf_ruleset γ p rs  wf_ruleset γ p (normalize_rules_dnf rs)"
  proof(induction rs)
  case Nil thus ?case by simp
  next
  case(Cons r rs)
    from Cons have IH: "wf_ruleset γ p (normalize_rules_dnf rs)" by(auto dest: wf_rulesetD) 
    from Cons.prems have "wf_ruleset γ p [r]" by(auto dest: wf_rulesetD) 
    hence "wf_ruleset γ p (normalize_rules_dnf [r])" using wf_ruleset_normalize_match by(cases r) simp
    with IH wf_ruleset_append have "wf_ruleset γ p (normalize_rules_dnf [r] @ normalize_rules_dnf rs)" by fast
    thus ?case using normalize_rules_dnf_def2 normalize_rules_fst by metis
  qed

lemma good_ruleset_normalize_rules_dnf: "good_ruleset rs  good_ruleset (normalize_rules_dnf rs)"
  using normalize_rules_dnf_def2 good_ruleset_normalize_rules by metis

lemma simple_ruleset_normalize_rules_dnf: "simple_ruleset rs  simple_ruleset (normalize_rules_dnf rs)"
  using normalize_rules_dnf_def2 simple_ruleset_normalize_rules by metis


(*This is the simple correctness proof, using the generalized version.
  below, we have a more complex correctness proof with a slighter generic assumption.
  Probably, we can delete the complex proof when we only focus on simple rulesets
  *)
lemma "simple_ruleset rs  
  approximating_bigstep_fun γ p (normalize_rules_dnf rs) s = approximating_bigstep_fun γ p rs s"
  unfolding normalize_rules_dnf_def2
  apply(rule normalize_rules_match_list_semantics)
   apply (metis matches_to_match_list_normalize)
  by simp
  
lemma normalize_rules_dnf_correct: "wf_ruleset γ p rs  
  approximating_bigstep_fun γ p (normalize_rules_dnf rs) s = approximating_bigstep_fun γ p rs s"
  proof(induction rs)
  case Nil thus ?case by simp
  next
  case (Cons r rs)
    show ?case
    proof(induction s rule: just_show_all_approximating_bigstep_fun_equalities_with_start_Undecided)
    case Undecided
    from Cons wf_rulesetD(2) have IH: "approximating_bigstep_fun γ p (normalize_rules_dnf rs) s = approximating_bigstep_fun γ p rs s" by fast
    from Cons.prems have "wf_ruleset γ p [r]" and "wf_ruleset γ p (normalize_rules_dnf [r])"
      by(auto dest: wf_rulesetD simp: wf_ruleset_normalize_rules_dnf)
    with IH Undecided have
      "approximating_bigstep_fun γ p (normalize_rules_dnf rs) (approximating_bigstep_fun γ p (normalize_rules_dnf [r]) Undecided) = approximating_bigstep_fun γ p (r # rs) Undecided"
      apply(cases r, rename_tac m a)
      apply(simp)
      apply(case_tac a)
              apply(simp_all add: normalize_match_correct Decision_approximating_bigstep_fun wf_ruleset_singleton)
      done
    hence "approximating_bigstep_fun γ p (normalize_rules_dnf [r] @ normalize_rules_dnf rs) s = approximating_bigstep_fun γ p (r # rs) s"
      using Undecided ‹wf_ruleset γ p [r] ‹wf_ruleset γ p (normalize_rules_dnf [r]) 
      by(simp add: approximating_bigstep_fun_seq_wf)
    thus ?thesis using normalize_rules_fst normalize_rules_dnf_def2 by metis
    qed
  qed


fun normalized_nnf_match :: "'a match_expr  bool" where
  "normalized_nnf_match MatchAny = True" |
  "normalized_nnf_match (Match _ ) = True" |
  "normalized_nnf_match (MatchNot (Match _)) = True" |
  "normalized_nnf_match (MatchAnd m1 m2) = ((normalized_nnf_match m1)  (normalized_nnf_match m2))" |
  "normalized_nnf_match _ = False"


text‹Essentially, @{term normalized_nnf_match} checks for a negation normal form: Only AND is at toplevel, negation only occurs in front of literals.
 Since @{typ "'a match_expr"} does not support OR, the result is in conjunction normal form.
 Applying @{const normalize_match}, the reuslt is a list. Essentially, this is the disjunctive normal form.›

lemma normalize_match_already_normalized: "normalized_nnf_match m  normalize_match m = [m]"
  by(induction m rule: normalize_match.induct) (simp)+

lemma normalized_nnf_match_normalize_match: " m'  set (normalize_match m). normalized_nnf_match m'"
  proof(induction m arbitrary: rule: normalize_match.induct)
  case 4 thus ?case by fastforce
  qed (simp_all)


lemma normalized_nnf_match_MatchNot_D: "normalized_nnf_match (MatchNot m)  normalized_nnf_match m"
  by(induction m) (simp_all)


text‹Example›
lemma "normalize_match (MatchNot (MatchAnd (Match ip_src) (Match tcp))) = [MatchNot (Match ip_src), MatchNot (Match tcp)]" by simp



subsection‹Functions which preserve @{const normalized_nnf_match}

lemma optimize_matches_option_normalized_nnf_match: "( r. r  set rs  normalized_nnf_match (get_match r)) 
     (m m'. normalized_nnf_match m  f m = Some m'  normalized_nnf_match m') 
       r  set (optimize_matches_option f rs). normalized_nnf_match (get_match r)"
    proof(induction rs)
      case Nil thus ?case by simp
    next
      case (Cons r rs)
      from Cons.IH Cons.prems have IH: "rset (optimize_matches_option f rs). normalized_nnf_match (get_match r)" by simp
      from Cons.prems have "rset (optimize_matches_option f [r]). normalized_nnf_match (get_match r)"
        apply(cases r)
        apply(simp split: option.split)
        by force (*1s*)
      with IH show ?case by(cases r, simp split: option.split_asm)
    qed



lemma optimize_matches_normalized_nnf_match: " r  set rs. normalized_nnf_match (get_match r); m. normalized_nnf_match m  normalized_nnf_match (f m)  
       r  set (optimize_matches f rs). normalized_nnf_match (get_match r)"
  unfolding optimize_matches_def
  apply(rule optimize_matches_option_normalized_nnf_match)
   apply(simp; fail)
  apply(simp split: if_split_asm)
  by blast


lemma normalize_rules_dnf_normalized_nnf_match: "x  set (normalize_rules_dnf rs). normalized_nnf_match (get_match x)"
  proof(induction rs)
  case Nil thus ?case by simp
  next
  case (Cons r rs) thus ?case using normalized_nnf_match_normalize_match by(cases r) fastforce
  qed

end

Theory Negation_Type_Matching

theory Negation_Type_Matching
imports  "../Common/Negation_Type" Matching_Ternary "../Datatype_Selectors" Normalized_Matches
begin

section‹Negation Type Matching›


text‹Transform a @{typ "'a negation_type list"} to a @{typ "'a match_expr"} via conjunction.›
fun alist_and :: "'a negation_type list  'a match_expr" where
  "alist_and [] = MatchAny" |
  "alist_and ((Pos e)#es) = MatchAnd (Match e) (alist_and es)" |
  "alist_and ((Neg e)#es) = MatchAnd (MatchNot (Match e)) (alist_and es)"

lemma normalized_nnf_match_alist_and: "normalized_nnf_match (alist_and as)"
  by(induction as rule: alist_and.induct) simp_all

lemma alist_and_append: "matches γ (alist_and (l1 @ l2)) a p  matches γ  (MatchAnd (alist_and l1)  (alist_and l2)) a p"
  proof(induction l1)
  case Nil thus ?case by (simp add: bunch_of_lemmata_about_matches)
  next
  case (Cons l l1) thus ?case by (cases l) (simp_all add: bunch_of_lemmata_about_matches)
  qed

  text‹This version of @{const alist_and} avoids the trailing @{const MatchAny}. Only intended for code.›
  fun alist_and' :: "'a negation_type list  'a match_expr" where
    "alist_and' [] = MatchAny" |
    "alist_and' [Pos e] = Match e" |
    "alist_and' [Neg e] = MatchNot (Match e)"|
    "alist_and' ((Pos e)#es) = MatchAnd (Match e) (alist_and' es)" |
    "alist_and' ((Neg e)#es) = MatchAnd (MatchNot (Match e)) (alist_and' es)"

  lemma alist_and': "matches (γ, α) (alist_and' as) = matches (γ, α) (alist_and as)"
    by(induction as rule: alist_and'.induct) (simp_all add: bunch_of_lemmata_about_matches)
 
  lemma normalized_nnf_match_alist_and': "normalized_nnf_match (alist_and' as)"
    by(induction as rule: alist_and'.induct) simp_all

  lemma matches_alist_and_alist_and':
    "matches γ (alist_and' ls) a p  matches γ (alist_and ls) a p"
    apply(induction ls rule: alist_and'.induct)
    by(simp add: bunch_of_lemmata_about_matches)+

  lemma alist_and'_append: "matches γ (alist_and' (l1 @ l2)) a p  matches γ (MatchAnd (alist_and' l1) (alist_and' l2)) a p"
    proof(induction l1)
    case Nil thus ?case by (simp add: bunch_of_lemmata_about_matches)
    next
    case (Cons l l1) thus ?case
      apply (cases l)
       by(simp_all add: matches_alist_and_alist_and' bunch_of_lemmata_about_matches)
    qed

lemma alist_and_NegPos_map_getNeg_getPos_matches: 
  "(mset (getNeg spts). matches γ (MatchNot (Match (C m))) a p) 
   (mset (getPos spts). matches γ (Match (C m)) a p)
    
    matches γ (alist_and (NegPos_map C spts)) a p"
  proof(induction spts rule: alist_and.induct)
  qed(auto simp add: bunch_of_lemmata_about_matches)


fun negation_type_to_match_expr_f :: "('a  'b)  'a negation_type  'b match_expr" where
  "negation_type_to_match_expr_f f (Pos a) = Match (f a)" |
  "negation_type_to_match_expr_f f (Neg a) = MatchNot (Match (f a))"

lemma alist_and_negation_type_to_match_expr_f_matches:
    "matches γ (alist_and (NegPos_map C spts)) a p 
        (mset spts. matches γ (negation_type_to_match_expr_f C m) a p)"
  proof(induction spts rule: alist_and.induct)
  qed(auto simp add: bunch_of_lemmata_about_matches)

definition negation_type_to_match_expr :: "'a negation_type  'a match_expr" where
  "negation_type_to_match_expr m  negation_type_to_match_expr_f id m"

lemma negation_type_to_match_expr_simps:
  "negation_type_to_match_expr (Pos e) = (Match e)"
  "negation_type_to_match_expr (Neg e) = (MatchNot (Match e))"
by(simp_all add: negation_type_to_match_expr_def)

lemma alist_and_negation_type_to_match_expr: "alist_and (n#es) =  MatchAnd (negation_type_to_match_expr n) (alist_and es)"
  by(cases n, simp_all add: negation_type_to_match_expr_simps)


fun to_negation_type_nnf :: "'a match_expr  'a negation_type list" where
 "to_negation_type_nnf MatchAny = []" |
 "to_negation_type_nnf (Match a) = [Pos a]" |
 "to_negation_type_nnf (MatchNot (Match a)) = [Neg a]" |
 "to_negation_type_nnf (MatchAnd a b) = (to_negation_type_nnf a) @ (to_negation_type_nnf b)" |
 "to_negation_type_nnf _ = undefined"


lemma "normalized_nnf_match m  matches γ (alist_and (to_negation_type_nnf m)) a p  = matches γ m a p"
  proof(induction m rule: to_negation_type_nnf.induct)
  qed(simp_all add: bunch_of_lemmata_about_matches alist_and_append)


text‹Isolating the matching semantics›
fun nt_match_list :: "('a, 'packet) match_tac  action  'packet  'a negation_type list  bool" where
  "nt_match_list _ _ _ [] = True" |
  "nt_match_list γ a p ((Pos x)#xs)  matches γ (Match x) a p  nt_match_list γ a p xs" |
  "nt_match_list γ a p ((Neg x)#xs)  matches γ (MatchNot (Match x)) a p  nt_match_list γ a p xs"

lemma nt_match_list_matches: "nt_match_list γ a p l  matches γ (alist_and l) a p"
  apply(induction l rule: alist_and.induct)
    apply(case_tac [!] γ)
    apply(simp_all add: bunch_of_lemmata_about_matches)
  done


lemma nt_match_list_simp: "nt_match_list γ a p ms  
      (m  set (getPos ms). matches γ (Match m) a p)  (m  set (getNeg ms). matches γ (MatchNot (Match m)) a p)"
  proof(induction γ a p ms rule: nt_match_list.induct)
  case 3 thus ?case by fastforce
  qed(simp_all)

lemma matches_alist_and: "matches γ (alist_and l) a p  (m  set (getPos l). matches γ (Match m) a p)  (m  set (getNeg l). matches γ (MatchNot (Match m)) a p)"
  using nt_match_list_matches nt_match_list_simp by fast




end

Theory Primitive_Normalization

theory Primitive_Normalization
imports Negation_Type_Matching
begin

section‹Primitive Normalization›

subsection‹Normalized Primitives›

text‹
  Test if a disc› is in the match expression.
  For example, it call tell whether there are some matches for Src ip›.
›
fun has_disc :: "('a  bool)  'a match_expr  bool" where
  "has_disc _ MatchAny = False" |
  "has_disc disc (Match a) = disc a" |
  "has_disc disc (MatchNot m) = has_disc disc m" |
  "has_disc disc (MatchAnd m1 m2) = (has_disc disc m1  has_disc disc m2)"

fun has_disc_negated :: "('a  bool)  bool  'a match_expr  bool" where
  "has_disc_negated _    _   MatchAny = False" |
  "has_disc_negated disc neg (Match a) = (if disc a then neg else False)" |
  "has_disc_negated disc neg (MatchNot m) = has_disc_negated disc (¬ neg) m" |
  "has_disc_negated disc neg (MatchAnd m1 m2) = (has_disc_negated disc neg m1  has_disc_negated disc neg m2)"

lemma "¬ has_disc_negated (λx::nat. x = 0) False (MatchAnd (Match 0) (MatchNot (Match 1)))" by eval
lemma "has_disc_negated (λx::nat. x = 0) False (MatchAnd (Match 0) (MatchNot (Match 0)))" by eval
lemma "has_disc_negated (λx::nat. x = 0) True (MatchAnd (Match 0) (MatchNot (Match 1)))" by eval
lemma "¬ has_disc_negated (λx::nat. x = 0) True (MatchAnd (Match 1) (MatchNot (Match 0)))" by eval
lemma "has_disc_negated (λx::nat. x = 0) True (MatchAnd (Match 0) (MatchNot (Match 0)))" by eval

― ‹We want false on the right hand side, because this is how the algorithm should be started›
lemma has_disc_negated_MatchNot:
  "has_disc_negated disc True (MatchNot m)  has_disc_negated disc False m"
  "has_disc_negated disc True m  has_disc_negated disc False (MatchNot m)"
  by(induction m) (simp_all)

lemma has_disc_negated_has_disc: "has_disc_negated disc neg m  has_disc disc m"
  apply(induction m arbitrary: neg)
     apply(simp_all split: if_split_asm)
  by blast

lemma has_disc_negated_positiv_has_disc: "has_disc_negated disc neg m  has_disc_negated disc (¬ neg) m  has_disc disc m"
by(induction disc neg m arbitrary: neg rule:has_disc_negated.induct) auto


lemma has_disc_negated_disj_split: 
    "has_disc_negated (λa. P a  Q a) neg m  has_disc_negated P neg m  has_disc_negated Q neg m"
  apply(induction "(λa. P a  Q a)" neg m rule: has_disc_negated.induct)
     apply(simp_all)
  by blast

lemma has_disc_alist_and: "has_disc disc (alist_and as)  ( a  set as. has_disc disc (negation_type_to_match_expr a))"
  proof(induction as rule: alist_and.induct)
  qed(simp_all add: negation_type_to_match_expr_simps)
lemma has_disc_negated_alist_and: "has_disc_negated disc neg (alist_and as)  ( a  set as. has_disc_negated disc neg (negation_type_to_match_expr a))"
  proof(induction as rule: alist_and.induct)
  qed(simp_all add: negation_type_to_match_expr_simps)
  

lemma has_disc_alist_and': "has_disc disc (alist_and' as)  ( a  set as. has_disc disc (negation_type_to_match_expr a))"
  proof(induction as rule: alist_and'.induct)
  qed(simp_all add: negation_type_to_match_expr_simps)
lemma has_disc_negated_alist_and': "has_disc_negated disc neg (alist_and' as)  ( a  set as. has_disc_negated disc neg (negation_type_to_match_expr a))"
  proof(induction as rule: alist_and'.induct)
  qed(simp_all add: negation_type_to_match_expr_simps)


lemma has_disc_alist_and'_append:
  "has_disc disc' (alist_and' (ls1 @ ls2)) 
      has_disc disc' (alist_and' ls1)  has_disc disc' (alist_and' ls2)"
apply(induction ls1 arbitrary: ls2 rule: alist_and'.induct)
    apply(simp_all)
 apply(case_tac [!] ls2)
   apply(simp_all)
done
lemma has_disc_negated_alist_and'_append:
  "has_disc_negated disc' neg (alist_and' (ls1 @ ls2)) 
      has_disc_negated disc' neg (alist_and' ls1)  has_disc_negated disc' neg (alist_and' ls2)"
apply(induction ls1 arbitrary: ls2 rule: alist_and'.induct)
    apply(simp_all)
 apply(case_tac [!] ls2)
   apply(simp_all)
done

lemma match_list_to_match_expr_not_has_disc: 
    "a. ¬ disc (X a)  ¬ has_disc disc (match_list_to_match_expr (map (Match  X) ls))"
  apply(induction ls)
   apply(simp; fail)
  by(simp add: MatchOr_def)


lemma "matches ((λx _. bool_to_ternary (disc x)), (λ_ _. False)) (Match x) a p  has_disc disc (Match x)"
by(simp add: match_raw_ternary bool_to_ternary_simps split: ternaryvalue.split )


fun normalized_n_primitive :: "(('a  bool) × ('a  'b))  ('b  bool)  'a match_expr  bool" where
  "normalized_n_primitive _ _ MatchAny = True" |
  "normalized_n_primitive (disc, sel) n (Match P) = (if disc P then n (sel P) else True)" |
  "normalized_n_primitive (disc, sel) n (MatchNot (Match P)) = (if disc P then False else True)" |
  "normalized_n_primitive (disc, sel) n (MatchAnd m1 m2) = (normalized_n_primitive (disc, sel) n m1  normalized_n_primitive (disc, sel) n m2)" |
  "normalized_n_primitive _ _ (MatchNot (MatchAnd _ _)) = False" |
  (*"normalized_n_primitive _ _ (MatchNot _) = True" *)
  "normalized_n_primitive _ _ (MatchNot (MatchNot _)) = False" | (*not nnf normalized*)
  "normalized_n_primitive _ _ (MatchNot MatchAny) = True"


lemma normalized_nnf_match_opt_MatchAny_match_expr:
  "normalized_nnf_match m  normalized_nnf_match (opt_MatchAny_match_expr m)"
  proof-
  have "normalized_nnf_match m  normalized_nnf_match (opt_MatchAny_match_expr_once m)"
  for m :: "'a match_expr"
  by(induction m rule: opt_MatchAny_match_expr_once.induct) (simp_all)
  thus "normalized_nnf_match m  normalized_nnf_match (opt_MatchAny_match_expr m)"
    apply(simp add: opt_MatchAny_match_expr_def)
    apply(induction rule: repeat_stabilize_induct)
     by(simp)+
  qed

lemma normalized_n_primitive_opt_MatchAny_match_expr:
  "normalized_n_primitive disc_sel f m  normalized_n_primitive disc_sel f (opt_MatchAny_match_expr m)"
  proof-

  have "normalized_n_primitive disc_sel f m  normalized_n_primitive disc_sel f (opt_MatchAny_match_expr_once m)"
  for m
    proof-
    { fix disc::"('a  bool)" and sel::"('a  'b)" and n m1 m2
      have "normalized_n_primitive (disc, sel) n (opt_MatchAny_match_expr_once m1) 
           normalized_n_primitive (disc, sel) n (opt_MatchAny_match_expr_once m2) 
           normalized_n_primitive (disc, sel) n m1  normalized_n_primitive (disc, sel) n m2 
           normalized_n_primitive (disc, sel) n (opt_MatchAny_match_expr_once (MatchAnd m1 m2))"
    by(induction "(MatchAnd m1 m2)" rule: opt_MatchAny_match_expr_once.induct) (auto)
    }note x=this
    assume "normalized_n_primitive disc_sel f m"
    thus ?thesis
      apply(induction disc_sel f m rule: normalized_n_primitive.induct)
            apply simp_all
      using x by simp
    qed
  from this show
    "normalized_n_primitive disc_sel f m  normalized_n_primitive disc_sel f (opt_MatchAny_match_expr m)"
    apply(simp add: opt_MatchAny_match_expr_def)
    apply(induction rule: repeat_stabilize_induct)
     by(simp)+ 
  qed


lemma normalized_n_primitive_imp_not_disc_negated:
  "wf_disc_sel (disc,sel) C  normalized_n_primitive (disc,sel) f m  ¬ has_disc_negated disc False m"
  apply(induction "(disc,sel)" f m rule: normalized_n_primitive.induct)
  by(simp add: wf_disc_sel.simps split: if_split_asm)+

lemma normalized_n_primitive_alist_and: "normalized_n_primitive disc_sel P (alist_and as) 
      ( a  set as. normalized_n_primitive disc_sel P (negation_type_to_match_expr a))"
  proof(induction as)
  case Nil thus ?case by simp
  next
  case (Cons a as) thus ?case
    apply(cases disc_sel, cases a)
    by(simp_all add: negation_type_to_match_expr_simps)
  qed

lemma normalized_n_primitive_alist_and': "normalized_n_primitive disc_sel P (alist_and' as) 
      ( a  set as. normalized_n_primitive disc_sel P (negation_type_to_match_expr a))"
  apply(cases disc_sel)
  apply(induction as rule: alist_and'.induct)
      by(simp_all add: negation_type_to_match_expr_simps)

lemma not_has_disc_NegPos_map: "a. ¬ disc (C a)  aset (NegPos_map C ls).
        ¬ has_disc disc (negation_type_to_match_expr a)"
by(induction C ls rule: NegPos_map.induct) (simp add: negation_type_to_match_expr_def)+

lemma not_has_disc_negated_NegPos_map: "a. ¬ disc (C a)  aset (NegPos_map C ls).
        ¬ has_disc_negated disc False (negation_type_to_match_expr a)"
by(induction C ls rule: NegPos_map.induct) (simp add: negation_type_to_match_expr_def)+

lemma normalized_n_primitive_impossible_map: "a. ¬ disc (C a) 
  mset (map (Match  (C  x)) ls).
     normalized_n_primitive (disc, sel) f m"
  apply(intro ballI)
  apply(induction ls)
   apply(simp; fail)
  apply(simp)
  apply(case_tac m, simp_all) (*3 cases are impossible*)
   apply(fastforce)
  by force

lemma normalized_n_primitive_alist_and'_append:
  "normalized_n_primitive (disc, sel) f (alist_and' (ls1 @ ls2)) 
      normalized_n_primitive (disc, sel) f (alist_and' ls1)  normalized_n_primitive (disc, sel) f (alist_and' ls2)"
apply(induction ls1 arbitrary: ls2 rule: alist_and'.induct)
    apply(simp_all)
 apply(case_tac [!] ls2)
   apply(simp_all)
done

lemma normalized_n_primitive_if_no_primitive: "normalized_nnf_match m  ¬ has_disc disc m  
       normalized_n_primitive (disc, sel) f m"
  by(induction "(disc, sel)" f m rule: normalized_n_primitive.induct) (simp)+

lemma normalized_n_primitive_false_eq_notdisc: "normalized_nnf_match m 
  normalized_n_primitive (disc, sel) (λ_. False) m  ¬ has_disc disc m"
proof -
  have "normalized_nnf_match m  false = (λ_. False) 
  ¬ has_disc disc m  normalized_n_primitive (disc, sel) false m" for false
  by(induction "(disc, sel)" false m rule: normalized_n_primitive.induct)
  (simp)+
  thus "normalized_nnf_match m  ?thesis" by simp
qed

lemma normalized_n_primitive_MatchAnd_combine_map: "normalized_n_primitive disc_sel f rst 
       m'  (λspt. Match (C spt)) ` set pts. normalized_n_primitive disc_sel f m' 
        m'  (λspt. MatchAnd (Match (C spt)) rst) ` set pts  normalized_n_primitive disc_sel f m'"
  by(induction disc_sel f m' rule: normalized_n_primitive.induct)
     fastforce+

subsection‹Primitive Extractor›

text‹
  The following function takes a tuple of functions (@{typ "(('a  bool) × ('a  'b))"}) and a @{typ "'a match_expr"}.
  The passed function tuple must be the discriminator and selector of the datatype package.
  primitive_extractor› filters the @{typ "'a match_expr"} and returns a tuple.
  The first element of the returned tuple is the filtered primitive matches, the second element is the remaining match expression.

  It requires a @{const normalized_nnf_match}.
›
fun primitive_extractor :: "(('a  bool) × ('a  'b))  'a match_expr  ('b negation_type list × 'a match_expr)" where
 "primitive_extractor _ MatchAny = ([], MatchAny)" |
 "primitive_extractor (disc,sel) (Match a) = (if disc a then ([Pos (sel a)], MatchAny) else ([], Match a))" |
 "primitive_extractor (disc,sel) (MatchNot (Match a)) = (if disc a then ([Neg (sel a)], MatchAny) else ([], MatchNot (Match a)))" |
 "primitive_extractor C (MatchAnd ms1 ms2) = (
        let (a1', ms1') = primitive_extractor C ms1; 
            (a2', ms2') = primitive_extractor C ms2
        in (a1'@a2', MatchAnd ms1' ms2'))" |
 "primitive_extractor _ _ = undefined"

text‹
  The first part returned by @{const primitive_extractor}, here as›:
    A list of primitive match expressions.
    For example, let m = MatchAnd (Src ip1) (Dst ip2)› then, using the src (disc, sel)›, the result is [ip1]›.
    Note that Src› is stripped from the result.

    The second part, here ms› is the match expression which was not extracted.

    Together, the first and second part match iff m› matches.
›


(*unused*)
lemma primitive_extractor_fst_simp2:
  fixes m'::"'a match_expr  'a match_expr  'a match_expr"
  shows "fst (case primitive_extractor (disc, sel) m1 of (a1', ms1')  case primitive_extractor (disc, sel) m2 of (a2', ms2')  (a1' @ a2', m' ms1' ms2')) =
           fst (primitive_extractor (disc, sel) m1) @ fst (primitive_extractor (disc, sel) m2)"
      apply(cases "primitive_extractor (disc, sel) m1", simp)
      apply(cases "primitive_extractor (disc, sel) m2", simp)
      done

theorem primitive_extractor_correct: assumes 
  "normalized_nnf_match m" and "wf_disc_sel (disc, sel) C" and "primitive_extractor (disc, sel) m = (as, ms)" 
  shows "matches γ (alist_and (NegPos_map C as)) a p  matches γ ms a p  matches γ m a p"
  and "normalized_nnf_match ms"
  and "¬ has_disc disc ms"
  and "disc2. ¬ has_disc disc2 m  ¬ has_disc disc2 ms"
  and "disc2 sel2. normalized_n_primitive (disc2, sel2) P m  normalized_n_primitive (disc2, sel2) P ms"
  and "disc2. ¬ has_disc_negated disc2 neg m  ¬ has_disc_negated disc2 neg ms"
  and "¬ has_disc disc m  as = []  ms = m"
  and "¬ has_disc_negated disc False m  getNeg as = []"
  and "has_disc disc m  as  []"
proof -
  ― ‹better simplification rule›
  from assms have assm3': "(as, ms) = primitive_extractor (disc, sel) m" by simp
  with assms(1) assms(2) show "matches γ (alist_and (NegPos_map C as)) a p  matches γ ms a p  matches γ m a p"
    proof(induction "(disc, sel)" m  arbitrary: as ms rule: primitive_extractor.induct)
    case 4 thus ?case
      apply(simp split: if_split_asm prod.split_asm add: NegPos_map_append)
      apply(auto simp add: alist_and_append bunch_of_lemmata_about_matches)
      done
    qed(simp_all add: bunch_of_lemmata_about_matches wf_disc_sel.simps split: if_split_asm)

  from assms(1) assm3' show "normalized_nnf_match ms"
    proof(induction "(disc, sel)" m  arbitrary: as ms rule: primitive_extractor.induct)
         case 2 thus ?case by(simp split: if_split_asm)
         next
         case 3 thus ?case by(simp split: if_split_asm)
         next
         case 4 thus ?case 
           apply(clarify) (*if i don't clarify, the simplifier loops*)
           apply(simp split: prod.split_asm)
           done
    qed(simp_all)

  from assms(1) assm3' show "¬ has_disc disc ms"
    proof(induction "(disc, sel)" m  arbitrary: as ms rule: primitive_extractor.induct)
    qed(simp_all split: if_split_asm prod.split_asm)


  from assms(1) assm3' show "disc2. ¬ has_disc disc2 m  ¬ has_disc disc2 ms"
    proof(induction "(disc, sel)" m  arbitrary: as ms rule: primitive_extractor.induct)
         case 2 thus ?case by(simp split: if_split_asm)
         next
         case 3 thus ?case by(simp split: if_split_asm)
         next
         case 4 thus ?case by(simp split: prod.split_asm)
    qed(simp_all)


  from assms(1) assm3' show "disc2. ¬ has_disc_negated disc2 neg m  ¬ has_disc_negated disc2 neg ms"
    proof(induction "(disc, sel)" m  arbitrary: as ms rule: primitive_extractor.induct)
         case 2 thus ?case by(simp split: if_split_asm)
         next
         case 3 thus ?case by(simp split: if_split_asm)
         next
         case 4 thus ?case by(simp split: prod.split_asm)
    qed(simp_all)


  from assms(1) assm3' show "disc2 sel2. normalized_n_primitive (disc2, sel2) P m  normalized_n_primitive (disc2, sel2) P ms"
    apply(induction "(disc, sel)" m  arbitrary: as ms rule: primitive_extractor.induct)
          apply(simp)
         apply(simp split: if_split_asm)
        apply(simp split: if_split_asm)
       apply(simp split: prod.split_asm)
      apply(simp_all)
    done

   from assms(1) assm3' show "¬ has_disc disc m  as = []  ms = m"
    proof(induction "(disc, sel)" m  arbitrary: as ms rule: primitive_extractor.induct)
    case 2 thus ?case by(simp split: if_split_asm)
    next
    case 3 thus ?case by(simp split: if_split_asm)
    next
    case 4 thus ?case by(auto split: prod.split_asm)
    qed(simp_all)

   from assms(1) assm3' show "¬ has_disc_negated disc False m  getNeg as = []"
    proof(induction "(disc, sel)" m  arbitrary: as ms rule: primitive_extractor.induct)
    case 2 thus ?case by(simp split: if_split_asm)
    next
    case 3 thus ?case by(simp split: if_split_asm)
    next
    case 4 thus ?case by(simp add: getNeg_append split: prod.split_asm)
    qed(simp_all)

   from assms(1) assm3' show "has_disc disc m  as  []"
    proof(induction "(disc, sel)" m  arbitrary: as ms rule: primitive_extractor.induct)
    case 4 thus ?case apply(simp split: prod.split_asm)
      by metis
    qed(simp_all)
qed


lemma has_disc_negated_primitive_extractor:
  assumes "normalized_nnf_match m"
  shows "has_disc_negated disc False m  (a. Neg a  set (fst (primitive_extractor (disc, sel) m)))"
proof -
  obtain as ms where asms: "primitive_extractor (disc, sel) m = (as, ms)" by fastforce
  hence "has_disc_negated disc False m  (a. Neg a  set as)"
    using assms proof(induction m arbitrary: as ms)
    case Match thus ?case
       by(simp split: if_split_asm) fastforce
    next
    case (MatchNot m)
      thus ?case
      proof(induction m)
      case Match thus ?case by (simp, fastforce)
      qed(simp_all)
    next
    case (MatchAnd m1 m2) thus ?case
      apply(cases "primitive_extractor (disc, sel) m1")
      apply(cases "primitive_extractor (disc, sel) m2")
      by auto
  qed(simp_all split: if_split_asm)
  thus ?thesis using asms by simp
qed



(*if i extract something and put it together again unchanged, things do not change*)
lemma primitive_extractor_reassemble_preserves:
  "wf_disc_sel (disc, sel) C 
   normalized_nnf_match m 
   P m 
   P MatchAny 
   primitive_extractor (disc, sel) m = (as, ms)  ― ‹turn eqality around to simplify proof›
   (m1 m2. P (MatchAnd m1 m2)  P m1  P m2) 
   (ls1 ls2. P (alist_and' (ls1 @ ls2))  P (alist_and' ls1)  P (alist_and' ls2)) 
   P (alist_and' (NegPos_map C as))"
  proof(induction "(disc, sel)" m  arbitrary: as ms rule: primitive_extractor.induct)
  case 2 thus ?case
    apply(simp split: if_split_asm)
    apply(clarify)
    by(simp add: wf_disc_sel.simps)
  next
  case 3 thus ?case
    apply(simp split: if_split_asm)
    apply(clarify)
    by(simp add: wf_disc_sel.simps)
  next
  case (4 m1 m2 as ms)
    from 4 show ?case
      apply(simp)
      apply(simp split: prod.split_asm)
      apply(clarify)
      apply(simp add: NegPos_map_append)
    done
qed(simp_all split: if_split_asm)

lemma primitive_extractor_reassemble_not_has_disc:
  "wf_disc_sel (disc, sel) C 
   normalized_nnf_match m  ¬ has_disc disc' m 
   primitive_extractor (disc, sel) m = (as, ms) 
     ¬ has_disc disc' (alist_and' (NegPos_map C as))"
  apply(rule primitive_extractor_reassemble_preserves)
        by(simp_all add: NegPos_map_append has_disc_alist_and'_append)

lemma primitive_extractor_reassemble_not_has_disc_negated:
  "wf_disc_sel (disc, sel) C 
   normalized_nnf_match m  ¬ has_disc_negated disc' neg m 
   primitive_extractor (disc, sel) m = (as, ms)  
     ¬ has_disc_negated disc' neg (alist_and' (NegPos_map C as))"
  apply(rule primitive_extractor_reassemble_preserves)
        by(simp_all add: NegPos_map_append has_disc_negated_alist_and'_append)

lemma primitive_extractor_reassemble_normalized_n_primitive:
  "wf_disc_sel (disc, sel) C 
   normalized_nnf_match m  normalized_n_primitive (disc1, sel1) f m 
   primitive_extractor (disc, sel) m = (as, ms) 
     normalized_n_primitive (disc1, sel1) f (alist_and' (NegPos_map C as))"
  apply(rule primitive_extractor_reassemble_preserves)
        by(simp_all add: NegPos_map_append normalized_n_primitive_alist_and'_append)



lemma primitive_extractor_matchesE: "wf_disc_sel (disc,sel) C  normalized_nnf_match m  primitive_extractor (disc, sel) m = (as, ms)
  
  (normalized_nnf_match ms  ¬ has_disc disc ms  (disc2. ¬ has_disc disc2 m  ¬ has_disc disc2 ms)  matches_other   matches γ ms a p)
  
  matches γ (alist_and (NegPos_map C as)) a p  matches_other   matches γ m a p"
using primitive_extractor_correct(1,2,3,4) by metis

lemma primitive_extractor_matches_lastE: "wf_disc_sel (disc,sel) C  normalized_nnf_match m  primitive_extractor (disc, sel) m = (as, ms)
  
  (normalized_nnf_match ms  ¬ has_disc disc ms  (disc2. ¬ has_disc disc2 m  ¬ has_disc disc2 ms)  matches γ ms a p)
  
  matches γ (alist_and (NegPos_map C as)) a p    matches γ m a p"
using primitive_extractor_correct(1,2,3,4) by metis

text‹The lemmas @{thm primitive_extractor_matchesE} and @{thm primitive_extractor_matches_lastE} can be used as
  erule to solve goals about consecutive application of @{const primitive_extractor}.
  They should be used as primitive_extractor_matchesE[OF wf_disc_sel_for_first_extracted_thing]›.
›



subsection‹Normalizing and Optimizing Primitives›
  text‹
    Normalize primitives by a function f› with type @{typ "'b negation_type list  'b list"}.
    @{typ "'b"} is a primitive type, e.g. ipt-ipv4range.
    f› takes a conjunction list of negated primitives and must compress them such that:
    \begin{enumerate}
      \item no negation occurs in the output
      \item the output is a disjunction of the primitives, i.e. multiple primitives in one rule are compressed to at most one primitive (leading to multiple rules)
    \end{enumerate}
    Example with IP addresses:
    \begin{verbatim}
      f [10.8.0.0/16, 10.0.0.0/8] = [10.0.0.0/8]  f compresses to one range
      f [10.0.0.0, 192.168.0.01] = []    range is empty, rule can be dropped
      f [Neg 41] = [{0..40}, {42..ipv4max}]   one rule is translated into multiple rules to translate negation
      f [Neg 41, {20..50}, {30..50}] = [{30..40}, {42..50}]   input: conjunction list, output disjunction list!
    \end{verbatim}
›
  definition normalize_primitive_extract :: "(('a  bool) × ('a  'b)) 
                               ('b  'a) 
                               ('b negation_type list  'b list) 
                               'a match_expr  
                               'a match_expr list" where 
    "normalize_primitive_extract (disc_sel) C f m  (case primitive_extractor (disc_sel) m 
                of (spts, rst)  map (λspt. (MatchAnd (Match (C spt))) rst) (f spts))"
  
                (*if f spts is empty, we get back an empty list. *)
  
  text‹
    If f› has the properties described above, then @{const normalize_primitive_extract} is a valid transformation of a match expression›
  lemma normalize_primitive_extract: assumes "normalized_nnf_match m" and "wf_disc_sel disc_sel C" and
        "ml. (match_list γ (map (Match  C) (f ml)) a p  matches γ (alist_and (NegPos_map C ml)) a p)"
        shows "match_list γ (normalize_primitive_extract disc_sel C f m) a p  matches γ m a p"
    proof -
      obtain as ms where pe: "primitive_extractor disc_sel m = (as, ms)" by fastforce

      from pe primitive_extractor_correct(1)[OF assms(1), where γ=γ and  a=a and p=p] assms(2) have 
        "matches γ m a p  matches γ (alist_and (NegPos_map C as)) a p  matches γ ms a p" by(cases disc_sel, blast)
      also have "  match_list γ (map (Match  C) (f as)) a p  matches γ ms a p" using assms(3) by simp
      also have "  match_list γ (map (λspt. MatchAnd (Match (C spt)) ms) (f as)) a p"
        by(simp add: match_list_matches bunch_of_lemmata_about_matches)
      also have "...  match_list γ (normalize_primitive_extract disc_sel C f m) a p"
        by(simp add: normalize_primitive_extract_def pe) 
      finally show ?thesis by simp
    qed

  thm match_list_semantics[of γ "(map (Match  C) (f ml))" a p "[(alist_and (NegPos_map C ml))]"]

  corollary normalize_primitive_extract_semantics:  assumes "normalized_nnf_match m" and "wf_disc_sel disc_sel C" and
        "ml. (match_list γ (map (Match  C) (f ml)) a p  matches γ (alist_and (NegPos_map C ml)) a p)"
        shows "approximating_bigstep_fun γ p (map (λm. Rule m a) (normalize_primitive_extract disc_sel C f m)) s = 
              approximating_bigstep_fun γ p [Rule m a] s"
  proof -
    from normalize_primitive_extract[OF assms(1) assms(2) assms(3)] have
      "match_list γ (normalize_primitive_extract disc_sel C f m) a p = matches γ m a p" .
    also have "  match_list γ [m] a p" by simp
    finally show ?thesis using match_list_semantics[of γ "(normalize_primitive_extract disc_sel C f m)" a p "[m]"] by simp
  qed


  lemma normalize_primitive_extract_preserves_nnf_normalized:
  assumes "normalized_nnf_match m"
      and "wf_disc_sel (disc, sel) C"
    shows "mn  set (normalize_primitive_extract (disc, sel) C f m). normalized_nnf_match mn"
    proof
      fix mn
      assume assm2: "mn  set (normalize_primitive_extract (disc, sel) C f m)"
      obtain as ms where as_ms: "primitive_extractor (disc, sel) m = (as, ms)" by fastforce
      from primitive_extractor_correct(2)[OF assms(1) assms(2) as_ms] have "normalized_nnf_match ms" by simp
      from assm2 as_ms have normalize_primitive_extract_unfolded: "mn  ((λspt. MatchAnd (Match (C spt)) ms) ` set (f as))"
        unfolding normalize_primitive_extract_def by force
      with ‹normalized_nnf_match ms show "normalized_nnf_match mn" by fastforce
    qed

  lemma normalize_rules_primitive_extract_preserves_nnf_normalized:
    "r  set rs. normalized_nnf_match (get_match r)  wf_disc_sel disc_sel C 
     r  set (normalize_rules (normalize_primitive_extract disc_sel C f) rs). normalized_nnf_match (get_match r)"
  apply(rule normalize_rules_preserves[where P="normalized_nnf_match" and f="(normalize_primitive_extract disc_sel C f)"])
   apply(simp; fail)
  apply(cases disc_sel)
  using normalize_primitive_extract_preserves_nnf_normalized by fast

  text‹If something is normalized for disc2 and disc2 ≠› disc1 and we do something on disc1, then disc2 remains normalized›
  lemma normalize_primitive_extract_preserves_unrelated_normalized_n_primitive:
  assumes "normalized_nnf_match m"
      and "normalized_n_primitive (disc2, sel2) P m"
      and "wf_disc_sel (disc1, sel1) C"
      and "a. ¬ disc2 (C a)" ― ‹disc1 and disc2 match for different stuff. e.g. @{text Src_Ports} and @{text Dst_Ports}
    shows "mn  set (normalize_primitive_extract (disc1, sel1) C f m). normalized_n_primitive (disc2, sel2) P mn"
    proof
      fix mn
      assume assm2: "mn  set (normalize_primitive_extract (disc1, sel1) C f m)"
      obtain as ms where as_ms: "primitive_extractor (disc1, sel1) m = (as, ms)" by fastforce
      from as_ms primitive_extractor_correct[OF assms(1) assms(3)] have 
                      "¬ has_disc disc1 ms"
                  and "normalized_n_primitive (disc2, sel2) P ms"
        apply -
        apply(fast)
        using assms(2) by(fast)
      from assm2 as_ms have normalize_primitive_extract_unfolded: "mn  ((λspt. MatchAnd (Match (C spt)) ms) ` set (f as))"
        unfolding normalize_primitive_extract_def by force
      
      from normalize_primitive_extract_unfolded obtain Casms where Casms: "mn = (MatchAnd (Match (C Casms)) ms)" by blast

      from ‹normalized_n_primitive (disc2, sel2) P ms assms(4) have "normalized_n_primitive (disc2, sel2) P (MatchAnd (Match (C Casms)) ms)"
        by(simp)

      with Casms show "normalized_n_primitive (disc2, sel2) P mn" by blast
    qed

  
  lemma normalize_primitive_extract_normalizes_n_primitive:
  fixes disc::"('a  bool)" and sel::"('a  'b)" and f::"('b negation_type list  'b list)"
  assumes "normalized_nnf_match m"
      and "wf_disc_sel (disc, sel) C"
      and np: "as. ( a'  set (f as). P a')" (*not quite, sel f   ∀as ∈ {x. disc (v x)}. *)
    shows "m'  set (normalize_primitive_extract (disc, sel) C f m). normalized_n_primitive (disc, sel) P m'"
    proof
    fix m' assume a: "m'set (normalize_primitive_extract (disc, sel) C f m)"

    have nnf: "m'  set (normalize_primitive_extract (disc, sel) C f m). normalized_nnf_match m'"
      using normalize_primitive_extract_preserves_nnf_normalized assms by blast
    with a have normalized_m': "normalized_nnf_match m'" by simp

    from a obtain as ms where as_ms: "primitive_extractor (disc, sel) m = (as, ms)"
      unfolding normalize_primitive_extract_def by fastforce
    with a have prems: "m'  set (map (λspt. MatchAnd (Match (C spt)) ms) (f as))"
      unfolding normalize_primitive_extract_def by simp


    from primitive_extractor_correct(2)[OF assms(1) assms(2) as_ms] have "normalized_nnf_match ms" .
    
    show "normalized_n_primitive (disc, sel) P m'"
    proof(cases "f as = []")
    case True thus "normalized_n_primitive (disc, sel) P m'" using prems by simp
    next
    case False
      with prems obtain spt where "m' = MatchAnd (Match (C spt)) ms" and "spt  set (f as)" by auto

      from primitive_extractor_correct(3)[OF assms(1) assms(2) as_ms] have "¬ has_disc disc ms" .
      with ‹normalized_nnf_match ms have "normalized_n_primitive (disc, sel) P ms"
        by(induction "(disc, sel)" P ms rule: normalized_n_primitive.induct) simp_all

      from ‹wf_disc_sel (disc, sel) C have "(sel (C spt)) = spt" by(simp add: wf_disc_sel.simps)
      with np spt  set (f as) have "P (sel (C spt))" by simp

      show "normalized_n_primitive (disc, sel) P m'"
      apply(simp add: m' = MatchAnd (Match (C spt)) ms)
      apply(rule conjI)
       apply(simp_all add: ‹normalized_n_primitive (disc, sel) P ms)
      apply(simp add: P (sel (C spt)))
      done
    qed
  qed

 lemma primitive_extractor_negation_type_matching1:
    assumes wf: "wf_disc_sel (disc, sel) C"
        and normalized: "normalized_nnf_match m"
        and a1: "primitive_extractor (disc, sel) m = (as, rest)"
        and a2: "matches γ m a p"
    shows "(mset (map C (getPos as)). matches γ (Match m) a p)  
           (mset (map C (getNeg as)). matches γ (MatchNot (Match m)) a p)"
  proof -
      from primitive_extractor_correct(1)[OF normalized wf a1] a2 have
        "matches γ (alist_and (NegPos_map C as)) a p  matches γ rest a p" by fast
      hence "matches γ (alist_and (NegPos_map C as)) a p" by blast
      with Negation_Type_Matching.matches_alist_and have
        "(mset (getPos (NegPos_map C as)). matches γ (Match m) a p)  
         (mset (getNeg (NegPos_map C as)). matches γ (MatchNot (Match m)) a p)" by metis
      with getPos_NegPos_map_simp2 getNeg_NegPos_map_simp2 show ?thesis by metis
  qed


text@{const normalized_n_primitive} does NOT imply @{const normalized_nnf_match}
lemma "m. normalized_n_primitive disc_sel f m  ¬ normalized_nnf_match m"
  by(rule_tac x="MatchNot MatchAny" in exI) (simp)


lemma remove_unknowns_generic_not_has_disc: "¬ has_disc C m  ¬ has_disc C (remove_unknowns_generic γ a m)"
  by(induction γ a m rule: remove_unknowns_generic.induct) (simp_all add: remove_unknowns_generic_simps2)

lemma remove_unknowns_generic_not_has_disc_negated: "¬ has_disc_negated C neg m  ¬ has_disc_negated C neg (remove_unknowns_generic γ a m)"
  by(induction γ a m rule: remove_unknowns_generic.induct) (simp_all add: remove_unknowns_generic_simps2)

lemma remove_unknowns_generic_normalized_n_primitive: "normalized_n_primitive disc_sel f m  
    normalized_n_primitive disc_sel f (remove_unknowns_generic γ a m)"
  proof(induction γ a m rule: remove_unknowns_generic.induct)
    case 6 thus ?case by(case_tac disc_sel, simp add: remove_unknowns_generic_simps2)
  qed(simp_all add: remove_unknowns_generic_simps2)



lemma normalize_match_preserves_disc_negated: 
    shows "(m_DNF  set (normalize_match m). has_disc_negated disc neg m_DNF)  has_disc_negated disc neg m"
  proof(induction m rule: normalize_match.induct)
  case 3 thus ?case by (simp) blast
  next
  case 4
    from 4 show ?case by(simp) blast
  qed(simp_all)
text@{const has_disc_negated} is a structural property and @{const normalize_match} is a semantical property.
  @{const normalize_match} removes subexpressions which cannot match. Thus, we cannot show (without complicated assumptions)
  the opposite direction of @{thm normalize_match_preserves_disc_negated}, because a negated primitive
  might occur in a subexpression which will be optimized away.›


corollary i_m_giving_this_a_funny_name_so_i_can_thank_my_future_me_when_sledgehammer_will_find_this_one_day:
  "¬ has_disc_negated disc neg m   m_DNF  set (normalize_match m). ¬ has_disc_negated disc neg m_DNF"
using normalize_match_preserves_disc_negated by blast


lemma not_has_disc_opt_MatchAny_match_expr:
  "¬ has_disc disc m  ¬ has_disc disc (opt_MatchAny_match_expr m)"
  proof -
    have "¬ has_disc disc m  ¬ has_disc disc (opt_MatchAny_match_expr_once m)" for m
    by(induction m rule: opt_MatchAny_match_expr_once.induct) simp_all
  thus "¬ has_disc disc m  ¬ has_disc disc (opt_MatchAny_match_expr m)"
    apply(simp add: opt_MatchAny_match_expr_def)
    apply(rule repeat_stabilize_induct)
     by(simp)+
  qed
lemma not_has_disc_negated_opt_MatchAny_match_expr:
  "¬ has_disc_negated disc neg m  ¬ has_disc_negated disc neg (opt_MatchAny_match_expr m)"
  proof -
    have "¬ has_disc_negated disc neg m  ¬ has_disc_negated disc neg (opt_MatchAny_match_expr_once m)"
    for m
    by(induction m arbitrary: neg rule:opt_MatchAny_match_expr_once.induct) (simp_all)
  thus "¬ has_disc_negated disc neg m  ¬ has_disc_negated disc neg (opt_MatchAny_match_expr m)"
    apply(simp add: opt_MatchAny_match_expr_def)
    apply(rule repeat_stabilize_induct)
     by(simp)+
  qed

lemma normalize_match_preserves_nodisc:
  "¬ has_disc disc m  m'  set (normalize_match m)  ¬ has_disc disc m'"
  proof - 
    (*no idea why this statement is necessary*)
    have "¬ has_disc disc m  (m'  set (normalize_match m). ¬ has_disc disc m')"
    by(induction m rule: normalize_match.induct) (safe,auto) ― ‹need safe, otherwise simplifier loops›
  thus "¬ has_disc disc m  m'  set (normalize_match m)  ¬ has_disc disc m'" by blast
qed

lemma not_has_disc_normalize_match:
  "¬ has_disc_negated disc neg  m  m'  set (normalize_match m)  ¬ has_disc_negated disc neg m'"
  using i_m_giving_this_a_funny_name_so_i_can_thank_my_future_me_when_sledgehammer_will_find_this_one_day by blast

lemma normalize_match_preserves_normalized_n_primitive:
  "normalized_n_primitive disc_sel f rst 
         m  set (normalize_match rst). normalized_n_primitive disc_sel f m"
apply(cases disc_sel, simp)
apply(induction rst rule: normalize_match.induct)
      apply(simp; fail)
     apply(simp; fail)
    apply(simp; fail)
   using normalized_n_primitive.simps(5) apply metis (*simp loops*)
  by simp+




subsection‹Optimizing a match expression›

  text‹Optimizes a match expression with a function that takes @{typ "'b negation_type list"}
  and returns @{typ "('b list × 'b list) option"}.
  The function should return @{const None} if the match expression cannot match.
  It returns @{term "Some (as_pos, as_neg)"} where @{term as_pos} and @{term as_neg} are lists of
  primitives. Positive and Negated.
  The result is one match expression.

  In contrast @{const normalize_primitive_extract} returns a list of match expression, to be read es their disjunction.›

  definition compress_normalize_primitive :: "(('a  bool) × ('a  'b))  ('b  'a) 
                                              ('b negation_type list  ('b list × 'b list) option)  
                                              'a match_expr  'a match_expr option" where 
    "compress_normalize_primitive disc_sel C f m  (case primitive_extractor disc_sel m of (as, rst) 
      (map_option (λ(as_pos, as_neg). MatchAnd
                                       (alist_and' (NegPos_map C ((map Pos as_pos)@(map Neg as_neg))))
                                       rst
                  ) (f as)))"



  lemma compress_normalize_primitive_nnf: "wf_disc_sel disc_sel C  
      normalized_nnf_match m  compress_normalize_primitive disc_sel C f m = Some m' 
    normalized_nnf_match m'"
    apply(case_tac "primitive_extractor disc_sel m")
    apply(simp add: compress_normalize_primitive_def)
    apply(clarify)
    apply (simp add: normalized_nnf_match_alist_and')
    apply(cases disc_sel, simp)
    using primitive_extractor_correct(2) by blast


  lemma compress_normalize_primitive_not_introduces_C:
    assumes notdisc: "¬ has_disc disc m"
        and wf: "wf_disc_sel (disc,sel) C'" (*C is allowed to be different from C'*)
        and nm: "normalized_nnf_match m"
        and some: "compress_normalize_primitive (disc,sel) C f m = Some m'"
        and f_preserves: "as_pos as_neg. f [] = Some (as_pos, as_neg)  as_pos = []  as_neg = []"
     shows "¬ has_disc disc m'"
   proof -
        obtain as ms where asms: "primitive_extractor (disc, sel) m = (as, ms)" by fastforce
        from notdisc primitive_extractor_correct(4)[OF nm wf asms] have 1: "¬ has_disc disc ms" by simp
        from notdisc primitive_extractor_correct(7)[OF nm wf asms] have 2: "as = []  ms = m" by simp
        from 1 2 some show ?thesis by(auto dest: f_preserves simp add: compress_normalize_primitive_def asms)
   qed

  lemma compress_normalize_primitive_not_introduces_C_negated:
    assumes notdisc: "¬ has_disc_negated disc False m"
        and wf: "wf_disc_sel (disc,sel) C"
        and nm: "normalized_nnf_match m"
        and some: "compress_normalize_primitive (disc,sel) C f m = Some m'"
        and f_preserves: "as as_pos as_neg. f as = Some (as_pos, as_neg)  getNeg as = []  as_neg = []"
     shows "¬ has_disc_negated disc False m'"
   proof -
        obtain as ms where asms: "primitive_extractor (disc,sel) m = (as, ms)" by fastforce
        from notdisc primitive_extractor_correct(6)[OF nm wf asms] have 1: "¬ has_disc_negated disc False ms" by simp
        from asms notdisc has_disc_negated_primitive_extractor[OF nm, where disc=disc and sel=sel] have
          "a. Neg a  set as" by(simp)
        hence "getNeg as = []" by (meson NegPos_set(5) image_subset_iff last_in_set)
        with f_preserves have f_preserves': "as_pos as_neg. f as = Some (as_pos, as_neg)  as_neg = []" by simp
        from 1 have " a b.¬ has_disc_negated disc False (MatchAnd (alist_and' (NegPos_map C (map Pos a))) ms)"
          by(simp add: has_disc_negated_alist_and' NegPos_map_map_Pos negation_type_to_match_expr_simps)
        with some show ?thesis by(auto dest: f_preserves' simp add: compress_normalize_primitive_def asms)
   qed




  lemma compress_normalize_primitive_Some:
  assumes normalized: "normalized_nnf_match m"
      and wf: "wf_disc_sel (disc,sel) C"
      and some: "compress_normalize_primitive (disc,sel) C f m = Some m'"
      and f_correct: "as as_pos as_neg. f as = Some (as_pos, as_neg) 
            matches γ (alist_and (NegPos_map C ((map Pos as_pos)@(map Neg as_neg)))) a p 
            matches γ (alist_and (NegPos_map C as)) a p"
    shows "matches γ m' a p  matches γ m a p"
    using some
    apply(simp add: compress_normalize_primitive_def)
    apply(case_tac "primitive_extractor (disc,sel) m")
    apply(rename_tac as rst, simp)
    apply(drule primitive_extractor_correct(1)[OF normalized wf, where γ=γ and a=a and p=p])
    apply(elim exE conjE)
    apply(drule f_correct)
    by (meson matches_alist_and_alist_and' bunch_of_lemmata_about_matches(1))
    

  lemma compress_normalize_primitive_None:
  assumes normalized: "normalized_nnf_match m"
      and wf: "wf_disc_sel (disc,sel) C"
      and none: "compress_normalize_primitive (disc,sel) C f m = None"
      and f_correct: "as. f as = None  ¬ matches γ (alist_and (NegPos_map C as)) a p"
    shows "¬ matches γ m a p"
    using none
    apply(simp add: compress_normalize_primitive_def)
    apply(case_tac "primitive_extractor (disc, sel) m")
    apply(auto dest: primitive_extractor_correct(1)[OF assms(1) wf] f_correct)
    done



  (* only for arbitrary discs that do not match C*)
  lemma compress_normalize_primitive_hasdisc:
    assumes am: "¬ has_disc disc2 m"
        and wf: "wf_disc_sel (disc,sel) C"
        and disc: "(a. ¬ disc2 (C a))"
        and nm: "normalized_nnf_match m"
        and some: "compress_normalize_primitive (disc,sel) C f m = Some m'"
     shows "normalized_nnf_match m'  ¬ has_disc disc2 m'"
   proof -
        from compress_normalize_primitive_nnf[OF wf nm some] have goal1: "normalized_nnf_match m'" .
        obtain as ms where asms: "primitive_extractor (disc, sel) m = (as, ms)" by fastforce
        from am primitive_extractor_correct(4)[OF nm wf asms] have 1: "¬ has_disc disc2 ms" by simp
        { fix is_pos is_neg
          from disc have x1: "¬ has_disc disc2 (alist_and' (NegPos_map C (map Pos is_pos)))"
            by(simp add: has_disc_alist_and' NegPos_map_map_Pos negation_type_to_match_expr_simps)
          from disc have x2: "¬ has_disc disc2 (alist_and' (NegPos_map C (map Neg is_neg)))"
            by(simp add: has_disc_alist_and' NegPos_map_map_Neg negation_type_to_match_expr_simps)
          from x1 x2 have "¬ has_disc disc2 (alist_and' (NegPos_map C (map Pos is_pos @ map Neg is_neg)))"
            apply(simp add: NegPos_map_append has_disc_alist_and') by blast
        }
        with some have "¬ has_disc disc2 m'"
          apply(simp add: compress_normalize_primitive_def asms)
          apply(elim exE conjE)
          using 1 by fastforce
        with goal1 show ?thesis by simp
   qed
  lemma compress_normalize_primitive_hasdisc_negated:
    assumes am: "¬ has_disc_negated disc2 neg m"
        and wf: "wf_disc_sel (disc,sel) C"
        and disc: "(a. ¬ disc2 (C a))"
        and nm: "normalized_nnf_match m"
        and some: "compress_normalize_primitive (disc,sel) C f m = Some m'"
     shows "normalized_nnf_match m'  ¬ has_disc_negated disc2 neg m'"
   proof -
        from compress_normalize_primitive_nnf[OF wf nm some] have goal1: "normalized_nnf_match m'" .
        obtain as ms where asms: "primitive_extractor (disc, sel) m = (as, ms)" by fastforce
        from am primitive_extractor_correct(6)[OF nm wf asms] have 1: "¬ has_disc_negated disc2 neg ms" by simp
        { fix is_pos is_neg
          from disc have x1: "¬ has_disc_negated disc2 neg (alist_and' (NegPos_map C (map Pos is_pos)))"
            by(simp add: has_disc_negated_alist_and' NegPos_map_map_Pos negation_type_to_match_expr_simps)
          from disc have x2: "¬ has_disc_negated disc2 neg (alist_and' (NegPos_map C (map Neg is_neg)))"
            by(simp add: has_disc_negated_alist_and' NegPos_map_map_Neg negation_type_to_match_expr_simps)
          from x1 x2 have "¬ has_disc_negated disc2 neg (alist_and' (NegPos_map C (map Pos is_pos @ map Neg is_neg)))"
            apply(simp add: NegPos_map_append has_disc_negated_alist_and') by blast
        }
        with some have "¬ has_disc_negated disc2 neg m'"
          apply(simp add: compress_normalize_primitive_def asms)
          apply(elim exE conjE)
          using 1 by fastforce
          
        with goal1 show ?thesis by simp
   qed


  thm normalize_primitive_extract_preserves_unrelated_normalized_n_primitive (*is similar*)
  lemma compress_normalize_primitve_preserves_normalized_n_primitive:
    assumes am: "normalized_n_primitive (disc2, sel2) P m"
        and wf: "wf_disc_sel (disc,sel) C"
        and disc: "(a. ¬ disc2 (C a))"
        and nm: "normalized_nnf_match m"
        and some: "compress_normalize_primitive (disc,sel) C f m = Some m'"
     shows "normalized_nnf_match m'  normalized_n_primitive (disc2, sel2) P m'"
   proof -
        from compress_normalize_primitive_nnf[OF wf nm some] have goal1: "normalized_nnf_match m'" .
        obtain as ms where asms: "primitive_extractor (disc, sel) m = (as, ms)" by fastforce
        from am primitive_extractor_correct[OF nm wf asms] have 1: "normalized_n_primitive (disc2, sel2) P ms" by fast
        { fix iss
          from disc have "normalized_n_primitive (disc2, sel2) P (alist_and (NegPos_map C iss))"
            apply(induction iss)
             apply(simp_all)
            apply(rename_tac i iss, case_tac i)
             apply(simp_all)
            done
        }
        with some have "normalized_n_primitive (disc2, sel2) P m'"
          apply(simp add: compress_normalize_primitive_def asms)
          apply(elim exE conjE)
          using 1 normalized_n_primitive_alist_and' normalized_n_primitive_alist_and
                 normalized_n_primitive.simps(4) by blast 
        with goal1 show ?thesis by simp
   qed



subsection‹Processing a list of normalization functions›

fun compress_normalize_primitive_monad :: "('a match_expr  'a match_expr option) list  'a match_expr  'a match_expr option" where
  "compress_normalize_primitive_monad [] m = Some m" |
  "compress_normalize_primitive_monad (f#fs) m = (case f m of None  None
                                                           |  Some m'  compress_normalize_primitive_monad fs m')"

lemma compress_normalize_primitive_monad: 
      assumes "m m' f. f  set fs  normalized_nnf_match m  f m = Some m'  matches γ m' a p  matches γ m a p"
          and "m m' f. f  set fs  normalized_nnf_match m  f m = Some m'  normalized_nnf_match m'"
          and "normalized_nnf_match m"
          and "(compress_normalize_primitive_monad fs m) = Some m'"
      shows "matches γ m' a p  matches γ m a p" (is ?goal1)
        and "normalized_nnf_match m'"              (is ?goal2)
  proof -
    (*everything in one big induction*)
    have goals: "?goal1  ?goal2"
    using assms proof(induction fs arbitrary: m)
    case Nil thus ?case by simp
    next
    case (Cons f fs)
      from Cons.prems(1) have IH_prem1:
        "(f m m'. f  set fs  normalized_nnf_match m  f m = Some m'  matches γ m' a p = matches γ m a p)" by auto
      from Cons.prems(2) have IH_prem2:
        "(f m m'. f  set fs  normalized_nnf_match m  f m = Some m'  normalized_nnf_match m')" by auto
      from Cons.IH IH_prem1 IH_prem2 have
        IH: "m. normalized_nnf_match m  compress_normalize_primitive_monad fs m = Some m' 
                  (matches γ m' a p  matches γ m a p)  ?goal2" by fast
      show ?case
        proof(cases "f m")
          case None thus ?thesis using Cons.prems by auto
        next
          case(Some m'')
            from Some Cons.prems(1)[of f] Cons.prems(3) have 1: "matches γ m'' a p = matches γ m a p" by simp
            from Some Cons.prems(2)[of f] Cons.prems(3) have 2: "normalized_nnf_match m''" by simp
            from Some have "compress_normalize_primitive_monad (f # fs) m = compress_normalize_primitive_monad fs m''" by simp
            thus ?thesis using Cons.prems(4) IH 1 2 by auto 
        qed
    qed
    from goals show ?goal1 by simp
    from goals show ?goal2 by simp
  qed

(*proof is a bit sledgehammered*)
lemma compress_normalize_primitive_monad_None: 
      assumes "m m' f. f  set fs  normalized_nnf_match m  f m = Some m'  matches γ m' a p  matches γ m a p"
          and "m f. f  set fs  normalized_nnf_match m  f m = None  ¬ matches γ m a p"
          and "m m' f. f  set fs  normalized_nnf_match m  f m = Some m'  normalized_nnf_match m'"
          and "normalized_nnf_match m"
          and "(compress_normalize_primitive_monad fs m) = None"
      shows "¬ matches γ m a p"
    using assms proof(induction fs arbitrary: m)
    case Nil thus ?case by simp
    next
    case (Cons f fs)
      from Cons.prems(1) have IH_prem1:
        "(f m m'. f  set fs  normalized_nnf_match m  f m = Some m'  matches γ m' a p = matches γ m a p)" by auto
      from Cons.prems(2) have IH_prem2:
        "(f m m'. f  set fs  normalized_nnf_match m  f m = None  ¬ matches γ m a p)" by auto
      from Cons.prems(3) have IH_prem3:
        "(f m m'. f  set fs  normalized_nnf_match m  f m = Some m'  normalized_nnf_match m')" by auto
      from Cons.IH IH_prem1 IH_prem2 IH_prem3 have
        IH: "m. normalized_nnf_match m  compress_normalize_primitive_monad fs m = None  ¬  matches γ m a p" by blast
      show ?case
        proof(cases "f m")
          case None thus ?thesis using Cons.prems(4) Cons.prems(2) Cons.prems(3) by auto
        next
          case(Some m'')
            from Some Cons.prems(3)[of f] Cons.prems(4) have 2: "normalized_nnf_match m''" by simp
            from Some have "compress_normalize_primitive_monad (f # fs) m = compress_normalize_primitive_monad fs m''" by simp
            hence "¬ matches γ m'' a p" using Cons.prems(5) IH 2 by simp
            thus ?thesis using Cons.prems(1) Cons.prems(4) Some by auto 
        qed
    qed


lemma compress_normalize_primitive_monad_preserves:
      assumes "m m' f. f  set fs  normalized_nnf_match m  f m = Some m'  normalized_nnf_match m'"
          and "m m' f. f  set fs  normalized_nnf_match m  P m  f m = Some m'  P m'"
          and "normalized_nnf_match m"
          and "P m"
          and "(compress_normalize_primitive_monad fs m) = Some m'"
      shows "normalized_nnf_match m'  P m'"
    using assms proof(induction fs arbitrary: m)
    case Nil thus ?case by simp
    next
    case (Cons f fs) thus ?case by(simp split: option.split_asm) blast (*1s*)
    qed




(*TODO: move to generic place and use? ? ? *)
datatype 'a match_compress = CannotMatch | MatchesAll | MatchExpr 'a


end

Theory MatchExpr_Fold

section‹Combine Match Expressions›
theory MatchExpr_Fold
imports Primitive_Normalization
begin

fun andfold_MatchExp :: "'a match_expr list  'a match_expr" where
  "andfold_MatchExp [] = MatchAny" |
  "andfold_MatchExp [e] = e" |
  "andfold_MatchExp (e#es) = MatchAnd e (andfold_MatchExp es)"

lemma andfold_MatchExp_alist_and: "alist_and' (map Pos ls) = andfold_MatchExp (map Match ls)"
  apply(induction ls)
   apply(simp)
  apply(simp)
  apply(rename_tac l ls)
  apply(case_tac "ls")
   by(simp)+

lemma andfold_MatchExp_matches:
  "matches γ (andfold_MatchExp ms) a p  (m  set ms. matches γ m a p)"
  apply(induction ms rule: andfold_MatchExp.induct)
    apply(simp add: bunch_of_lemmata_about_matches)+
  done

lemma andfold_MatchExp_not_discI:
  "m  set ms. ¬ has_disc disc m  ¬ has_disc disc (andfold_MatchExp ms)"
  by(induction ms rule: andfold_MatchExp.induct) (simp)+

lemma andfold_MatchExp_not_disc_negatedI:
  "m  set ms. ¬ has_disc_negated disc neg m  ¬ has_disc_negated disc neg (andfold_MatchExp ms)"
  by(induction ms rule: andfold_MatchExp.induct) (simp)+

lemma andfold_MatchExp_not_disc_negated_mapMatch:
  "¬ has_disc_negated disc False (andfold_MatchExp (map (Match  C) ls))"
  apply(induction ls)
   apply(simp; fail)
  apply(simp)
   apply(rename_tac ls, case_tac ls)
  by(simp)+

lemma andfold_MatchExp_not_disc_mapMatch:
  "a. ¬ disc (C a)  ¬ has_disc disc (andfold_MatchExp (map (Match  C) ls))"
  apply(induction ls)
   apply(simp; fail)
  apply(simp)
   apply(rename_tac ls, case_tac ls)
  by(simp)+

lemma andfold_MatchExp_normalized_nnf: "m  set ms. normalized_nnf_match m 
    normalized_nnf_match (andfold_MatchExp ms)"
  by(induction ms rule: andfold_MatchExp.induct)(simp)+

lemma andfold_MatchExp_normalized_n_primitive: "m  set ms. normalized_n_primitive (disc, sel) f m 
    normalized_n_primitive (disc, sel) f (andfold_MatchExp ms)"
  by(induction ms rule: andfold_MatchExp.induct)(simp)+

lemma andfold_MatchExp_normalized_normalized_n_primitive_single:
    "a. ¬ disc (C a) 
      s  set (normalize_match (andfold_MatchExp (map (Match  C) xs))) 
         normalized_n_primitive (disc, sel) f s"
  apply(rule normalized_n_primitive_if_no_primitive)
   using normalized_nnf_match_normalize_match apply blast
  apply(rule normalize_match_preserves_nodisc[where m="(andfold_MatchExp (map (Match  C) xs))"])
   apply simp_all
  by (simp add: andfold_MatchExp_not_discI)

lemma normalize_andfold_MatchExp_normalized_n_primitive:
  " m  set ms.  s'  set (normalize_match m). normalized_n_primitive (disc, sel) f s' 
        s  set (normalize_match (andfold_MatchExp ms)) 
          normalized_n_primitive (disc, sel) f s"
  proof(induction ms arbitrary: s rule: andfold_MatchExp.induct)
  case 1 thus ?case by simp
  next
  case 2 thus ?case by simp
  next
  case (3 v1 v2 va)
    have IH: "s'  set (normalize_match (andfold_MatchExp (v2 # va))) 
            normalized_n_primitive (disc, sel) f s'" for s'
    using 3(1)[of s'] (*without this, simp loops*)
    apply(simp)
    using 3(2) by force
    from 3(2,3) IH show ?case by(clarsimp)
  qed
end

Theory Common_Primitive_Lemmas

theory Common_Primitive_Lemmas
imports Common_Primitive_Matcher
        "../Semantics_Ternary/Primitive_Normalization"
        "../Semantics_Ternary/MatchExpr_Fold"
begin

section‹Further Lemmas about the Common Matcher›

lemma has_unknowns_common_matcher: fixes m::"'i::len common_primitive match_expr"
  shows "has_unknowns common_matcher m  has_disc is_Extra m"
  proof -
  { fix A and p :: "('i, 'a) tagged_packet_scheme"
    have "common_matcher A p = TernaryUnknown  is_Extra A"
      by(induction A p rule: common_matcher.induct) (simp_all add: bool_to_ternary_Unknown)
  } hence "β = (common_matcher::('i::len common_primitive, ('i, 'a) tagged_packet_scheme) exact_match_tac)
             has_unknowns β m = has_disc is_Extra m" for β
  by(induction β m rule: has_unknowns.induct)
    (simp_all)
  thus ?thesis by simp
qed



end

Theory Ports_Normalize

theory Ports_Normalize
imports Common_Primitive_Lemmas
begin


section‹Normalizing L4 Ports›
subsection‹Defining Normalized Ports›
  
  fun normalized_src_ports :: "'i::len common_primitive match_expr  bool" where
    "normalized_src_ports MatchAny = True" |
    "normalized_src_ports (Match (Src_Ports (L4Ports _ []))) = True" |
    "normalized_src_ports (Match (Src_Ports (L4Ports _ [_]))) = True" |
    "normalized_src_ports (Match (Src_Ports _)) = False" |
    "normalized_src_ports (Match _) = True" |
    "normalized_src_ports (MatchNot (Match (Src_Ports _))) = False" |
    "normalized_src_ports (MatchNot (Match _)) = True" |
    "normalized_src_ports (MatchAnd m1 m2) = (normalized_src_ports m1  normalized_src_ports m2)" |
    "normalized_src_ports (MatchNot (MatchAnd _ _)) = False" |
    "normalized_src_ports (MatchNot (MatchNot _)) = False" |
    "normalized_src_ports (MatchNot MatchAny) = True"
  
  fun normalized_dst_ports :: "'i::len common_primitive match_expr  bool" where
    "normalized_dst_ports MatchAny = True" |
    "normalized_dst_ports (Match (Dst_Ports (L4Ports _ []))) = True" |
    "normalized_dst_ports (Match (Dst_Ports (L4Ports _ [_]))) = True" |
    "normalized_dst_ports (Match (Dst_Ports _)) = False" |
    "normalized_dst_ports (Match _) = True" |
    "normalized_dst_ports (MatchNot (Match (Dst_Ports _))) = False" |
    "normalized_dst_ports (MatchNot (Match _)) = True" |
    "normalized_dst_ports (MatchAnd m1 m2) = (normalized_dst_ports m1  normalized_dst_ports m2)" |
    "normalized_dst_ports (MatchNot (MatchAnd _ _)) = False" |
    "normalized_dst_ports (MatchNot (MatchNot _)) = False" |
    "normalized_dst_ports (MatchNot MatchAny) = True" 

  lemma normalized_src_ports_def2: "normalized_src_ports ms = normalized_n_primitive (is_Src_Ports, src_ports_sel) (λps. case ps of L4Ports _ pts  length pts  1) ms"
    by(induction ms rule: normalized_src_ports.induct, simp_all)
  lemma normalized_dst_ports_def2: "normalized_dst_ports ms = normalized_n_primitive (is_Dst_Ports, dst_ports_sel) (λps. case ps of L4Ports _ pts  length pts  1) ms"
    by(induction ms rule: normalized_dst_ports.induct, simp_all)



text‹Idea: first, remove all negated matches, then @{const normalize_match},
  then only work with @{const primitive_extractor} on @{const Pos} ones.
  They only need an intersect and split later on. 

  This is not very efficient because normalizing nnf will blow up a lot.
  but we can tune performance later on go for correctness first!
  Anything with @{const MatchOr} and @{const normalize_match} later is a bit inefficient.
›




subsection‹Compressing Positive Matches on Ports into a Single Match›
(*compressing positive matches on ports into a single match*)

  fun l4_ports_compress :: "ipt_l4_ports list  ipt_l4_ports match_compress" where
    "l4_ports_compress [] = MatchesAll" | 
    "l4_ports_compress [L4Ports proto ps] = MatchExpr (L4Ports proto (wi2l (wordinterval_compress (l2wi ps))))" |
    "l4_ports_compress (L4Ports proto1 ps1 # L4Ports proto2 ps2 # pss) =
      (if
          proto1  proto2
       then
         CannotMatch
       else
         l4_ports_compress (L4Ports proto1 (wi2l (wordinterval_intersection (l2wi ps1) (l2wi ps2))) # pss)
      )"

  value[code] "l4_ports_compress [L4Ports TCP [(22,22), (23,23)]]"
  
  (*only for src*)
  lemma raw_ports_compress_src_CannotMatch:
  fixes p :: "('i::len, 'a) tagged_packet_scheme"
  assumes generic: "primitive_matcher_generic β"
  and c: "l4_ports_compress pss = CannotMatch"
  shows "¬ matches (β, α) (alist_and (map (Pos  Src_Ports) pss)) a p"
  using c apply(induction pss rule: l4_ports_compress.induct)
    apply(simp; fail)
   apply(simp; fail)
  apply(simp add: primitive_matcher_generic.Ports_single[OF generic] bunch_of_lemmata_about_matches split: if_split_asm)
   apply meson
  by(simp add: l2wi_wi2l ports_to_set_wordinterval)

  lemma raw_ports_compress_dst_CannotMatch:
  fixes p :: "('i::len, 'a) tagged_packet_scheme"
  assumes generic: "primitive_matcher_generic β"
  and c: "l4_ports_compress pss = CannotMatch"
  shows "¬ matches (β, α) (alist_and (map (Pos  Dst_Ports) pss)) a p"
  using c apply(induction pss rule: l4_ports_compress.induct)
    apply(simp; fail)
   apply(simp; fail)
  apply(simp add: primitive_matcher_generic.Ports_single[OF generic] bunch_of_lemmata_about_matches split: if_split_asm)
   apply meson
  by(simp add: l2wi_wi2l ports_to_set_wordinterval)

  lemma l4_ports_compress_length_Matchall: "length pss > 0  l4_ports_compress pss  MatchesAll"
    by(induction pss rule: l4_ports_compress.induct) simp+

  lemma raw_ports_compress_MatchesAll:
  fixes p :: "('i::len, 'a) tagged_packet_scheme"
  assumes generic: "primitive_matcher_generic β"
  and c: "l4_ports_compress pss = MatchesAll"
  shows "matches (β, α) (alist_and (map (Pos  Src_Ports) pss)) a p"
  and "matches (β, α) (alist_and (map (Pos  Dst_Ports) pss)) a p"
  using c apply(induction pss rule: l4_ports_compress.induct)
  by(simp add: l4_ports_compress_length_Matchall bunch_of_lemmata_about_matches split: if_split_asm)+

  lemma raw_ports_compress_src_MatchExpr:
  fixes p :: "('i::len, 'a) tagged_packet_scheme"
  assumes generic: "primitive_matcher_generic β"
  and c: "l4_ports_compress pss = MatchExpr m"
  shows "matches (β, α) (Match (Src_Ports m)) a p  matches (β, α) (alist_and (map (Pos  Src_Ports) pss)) a p"
  using c apply(induction pss arbitrary: m rule: l4_ports_compress.induct)
    apply(simp add: bunch_of_lemmata_about_matches; fail)
   subgoal
   apply(simp add: bunch_of_lemmata_about_matches)
   apply(drule sym, simp)
   by(simp add: primitive_matcher_generic.Ports_single[OF generic] wordinterval_compress l2wi_wi2l ports_to_set_wordinterval)
  apply(case_tac m)
  apply(simp add: bunch_of_lemmata_about_matches split: if_split_asm)
  apply(simp add: primitive_matcher_generic.Ports_single[OF generic])
  apply(simp add: l2wi_wi2l ports_to_set_wordinterval)
  by fastforce
  
  lemma raw_ports_compress_dst_MatchExpr:
  fixes p :: "('i::len, 'a) tagged_packet_scheme"
  assumes generic: "primitive_matcher_generic β"
  and c: "l4_ports_compress pss = MatchExpr m"
  shows "matches (β, α) (Match (Dst_Ports m)) a p  matches (β, α) (alist_and (map (Pos  Dst_Ports) pss)) a p"
  using c apply(induction pss arbitrary: m rule: l4_ports_compress.induct)
    apply(simp add: bunch_of_lemmata_about_matches; fail)
   subgoal
   apply(simp add: bunch_of_lemmata_about_matches)
   apply(drule sym, simp)
   by(simp add: primitive_matcher_generic.Ports_single[OF generic] wordinterval_compress l2wi_wi2l ports_to_set_wordinterval)
  apply(case_tac m)
  apply(simp add: bunch_of_lemmata_about_matches split: if_split_asm)
  apply(simp add: primitive_matcher_generic.Ports_single[OF generic])
  apply(simp add: l2wi_wi2l ports_to_set_wordinterval)
  by fastforce


subsection‹Rewriting Negated Matches on Ports›

  fun l4_ports_negate_one
    :: "(ipt_l4_ports  'i common_primitive)  ipt_l4_ports  ('i::len common_primitive) match_expr"
  where
    "l4_ports_negate_one C (L4Ports proto pts) = MatchOr
           (MatchNot (Match (Prot (Proto proto))))
            (Match (C (L4Ports proto (raw_ports_invert pts))))"

  lemma l4_ports_negate_one:
  fixes p :: "('i::len, 'a) tagged_packet_scheme"
  assumes generic: "primitive_matcher_generic β"
  shows "matches (β, α) (l4_ports_negate_one Src_Ports ports) a p 
          matches (β, α) (MatchNot (Match (Src_Ports ports))) a p"
  and "matches (β, α) (l4_ports_negate_one Dst_Ports ports) a p 
          matches (β, α) (MatchNot (Match (Dst_Ports ports))) a p"
    apply(case_tac [!] ports)
    by(auto simp add: primitive_matcher_generic.Ports_single_not[OF generic]
                    MatchOr bunch_of_lemmata_about_matches
                    primitive_matcher_generic.Prot_single_not[OF generic]
                    primitive_matcher_generic.Ports_single[OF generic]
                    raw_ports_invert)

  lemma l4_ports_negate_one_nodisc:
    "a. ¬ disc (C a)  a. ¬ disc (Prot a)  ¬ has_disc disc (l4_ports_negate_one C pt)"
      apply(cases pt)
      by(simp add: MatchOr_def)

  lemma l4_ports_negate_one_not_has_disc_negated_generic:
    assumes noProt: "a. ¬ disc (Prot a)"
    shows "¬ has_disc_negated disc False (l4_ports_negate_one C ports)"
    apply(cases ports, rename_tac proto pts)
    by(simp add: MatchOr_def noProt)

  lemma l4_ports_negate_one_not_has_disc_negated:
    "¬ has_disc_negated is_Src_Ports False (l4_ports_negate_one Src_Ports ports)"
    "¬ has_disc_negated is_Dst_Ports False (l4_ports_negate_one Dst_Ports ports)"
    by(simp add: l4_ports_negate_one_not_has_disc_negated_generic)+
    
  lemma negated_normalized_folded_ports_nodisc:
    "a. ¬ disc (C a)  (a. ¬ disc (Prot a))  pts = [] 
     m  set (normalize_match (andfold_MatchExp (map (l4_ports_negate_one C) pts))) 
      ¬ has_disc disc m"
    apply(subgoal_tac "¬ has_disc disc (andfold_MatchExp (map (l4_ports_negate_one C) pts))")
     prefer 2
     apply(rule andfold_MatchExp_not_discI)
     apply(simp)
     apply(elim disjE)
      using l4_ports_negate_one_nodisc apply blast
     apply(simp; fail)
    using normalize_match_preserves_nodisc by blast
  
  lemma negated_normalized_folded_ports_normalized_n_primitive:
    "a. ¬ disc (C a)  (a. ¬ disc (Prot a))  pts = [] 
     x  set (normalize_match (andfold_MatchExp (map (l4_ports_negate_one C) pts))) 
      normalized_n_primitive (disc, sel) f x"
    apply(rule normalized_n_primitive_if_no_primitive)
     using normalized_nnf_match_normalize_match apply blast
    apply(rule negated_normalized_folded_ports_nodisc)
    by simp_all


  text‹beware, the result is not nnf normalized!›
  lemma "¬ normalized_nnf_match (l4_ports_negate_one C ports)"
    by(cases ports) (simp add: MatchOr_def)
  
  text‹Warning: does not preserve negated primitive property in general.
       Might be violated for @{const Prot}. We will nnf normalize after applying the function.›
  lemma "a. ¬ disc (C a)  ¬ normalized_n_primitive (disc, sel) f (l4_ports_negate_one C a)"
    by(cases a)(simp add: MatchOr_def)

  declare l4_ports_negate_one.simps[simp del]

    
  lemma "((normalize_match (l4_ports_negate_one Src_Ports (L4Ports TCP [(22,22),(80,90)]))):: 32 common_primitive match_expr list)
    =
    [ MatchNot (Match (Prot (Proto TCP)))
    , Match (Src_Ports (L4Ports 6 [(0, 21), (23, 79), (91, 0xFFFF)]))]" by eval

  (*TODO: this one is generic, move?*)
  definition rewrite_negated_primitives
    :: "(('a  bool) × ('a  'b))  ('b  'a)  ― ‹disc_sel C›
        (('b  'a)  'b  'a match_expr)  ― ‹negate_one› function›
        'a match_expr  'a match_expr" where
    "rewrite_negated_primitives disc_sel C negate m 
        let (spts, rst) = primitive_extractor disc_sel m
        in if getNeg spts = [] then m else 
          MatchAnd
            (andfold_MatchExp (map (negate C) (getNeg spts)))
            (MatchAnd
              (andfold_MatchExp (map (Match  C) (getPos spts))) ― ‹TODO: compress all the positive ports into one?›
            rst)"

  text‹It does nothing of there is not even a negated primitive in it›
  lemma rewrite_negated_primitives_unchanged_if_not_has_disc_negated:
  assumes n: "normalized_nnf_match m"
  and wf_disc_sel: "wf_disc_sel (disc,sel) C"
  and noDisc: "¬ has_disc_negated disc False m"
  shows "rewrite_negated_primitives (disc,sel) C negate_f m = m"
    apply(simp add: rewrite_negated_primitives_def)
    apply(case_tac "primitive_extractor (disc,sel) m", rename_tac spts rst)
    apply(simp)
    apply(frule primitive_extractor_correct(8)[OF n wf_disc_sel])
    using noDisc by blast  

  lemma rewrite_negated_primitives_normalized_no_modification:
    assumes wf_disc_sel: "wf_disc_sel (disc, sel) C"
    and disc_p: "¬ has_disc_negated disc False m"
    and n: "normalized_nnf_match m"
    and a: "a  set (normalize_match (rewrite_negated_primitives (disc, sel) C l4_ports_negate_one m))"
    shows "a = m"
    proof -
      from rewrite_negated_primitives_unchanged_if_not_has_disc_negated[OF n wf_disc_sel disc_p]
      have m: "rewrite_negated_primitives (disc, sel) C l4_ports_negate_one m = m" by simp
      from a show ?thesis
        apply(subst(asm) m)
        using normalize_match_already_normalized[OF n] by fastforce
    qed

  lemma rewrite_negated_primitives_preserves_not_has_disc:
  assumes n: "normalized_nnf_match m"
  and wf_disc_sel: "wf_disc_sel (disc, sel) C"
  and nodisc: "¬ has_disc disc2 m"
  and noNeg: "¬ has_disc_negated disc False m"
  and disc2_noC: "a. ¬ disc2 (C a)"
  shows "¬ has_disc disc2 (rewrite_negated_primitives (disc, sel) C l4_ports_negate_one m)"
    apply(subst rewrite_negated_primitives_unchanged_if_not_has_disc_negated)
    using n wf_disc_sel noNeg nodisc by(simp)+

  lemma rewrite_negated_primitives:
  assumes n: "normalized_nnf_match m" and wf_disc_sel: "wf_disc_sel disc_sel C"
  and negate_f: "pts. matches γ (negate_f C pts) a p  matches γ (MatchNot (Match (C pts))) a p"
  shows "matches γ (rewrite_negated_primitives disc_sel C negate_f m) a p  matches γ m a p"
  proof -
    obtain spts rst where pext: "primitive_extractor disc_sel m = (spts, rst)"
      by(cases "primitive_extractor disc_sel m") simp
    obtain disc sel where disc_sel: "disc_sel = (disc, sel)" by(cases disc_sel) simp
    with wf_disc_sel have wf_disc_sel': "wf_disc_sel (disc, sel) C" by simp
    from disc_sel pext have pext': "primitive_extractor (disc, sel) m = (spts, rst)" by simp
      
    have "matches γ (andfold_MatchExp (map (negate_f C) (getNeg spts))) a p 
          matches γ (andfold_MatchExp (map (Match  C) (getPos spts))) a p  matches γ rst a p 
       matches γ m a p"
      apply(subst primitive_extractor_correct(1)[OF n wf_disc_sel' pext', symmetric])
      apply(simp add: andfold_MatchExp_matches)
      apply(simp add: negate_f)
      using alist_and_NegPos_map_getNeg_getPos_matches by fast
    thus ?thesis by(simp add: rewrite_negated_primitives_def pext bunch_of_lemmata_about_matches)
  qed
 

  lemma rewrite_negated_primitives_not_has_disc:
  assumes n: "normalized_nnf_match m" and wf_disc_sel: "wf_disc_sel (disc,sel) C"
  and nodisc: "¬ has_disc disc2 m"
  (*only need a condition for negate_f if it is actually applied*)
  and negate_f: "has_disc_negated disc False m  pts. ¬ has_disc disc2 (negate_f C pts)"
  and no_disc: "a. ¬ disc2 (C a)"
  shows  "¬ has_disc disc2 (rewrite_negated_primitives (disc,sel) C negate_f m)"
    apply(simp add: rewrite_negated_primitives_def)
    apply(case_tac "primitive_extractor (disc,sel) m", rename_tac spts rst)
    apply(simp)
    apply(frule primitive_extractor_correct(4)[OF n wf_disc_sel])
    apply(frule primitive_extractor_correct(8)[OF n wf_disc_sel])
    apply(intro conjI impI)
       using nodisc apply(simp; fail)
      apply(rule andfold_MatchExp_not_discI)
      apply(simp add: negate_f; fail)
     using andfold_MatchExp_not_disc_mapMatch no_disc apply blast
     using nodisc by blast

  lemma rewrite_negated_primitives_not_has_disc_negated:
  assumes n: "normalized_nnf_match m" and wf_disc_sel: "wf_disc_sel (disc,sel) C"
  and negate_f: "has_disc_negated disc False m  pts. ¬ has_disc_negated disc False (negate_f C pts)"
  shows  "¬ has_disc_negated disc False (rewrite_negated_primitives (disc,sel) C negate_f m)"
    apply(simp add: rewrite_negated_primitives_def)
    apply(case_tac "primitive_extractor (disc,sel) m", rename_tac spts rst)
    apply(simp)
    apply(frule primitive_extractor_correct(3)[OF n wf_disc_sel])
    apply(frule primitive_extractor_correct(8)[OF n wf_disc_sel])
    apply(intro conjI impI)
       apply blast
      apply(rule andfold_MatchExp_not_disc_negatedI)
      apply(simp add: negate_f; fail)
     using andfold_MatchExp_not_disc_negated_mapMatch apply blast
    using has_disc_negated_has_disc by blast


  lemma rewrite_negated_primitives_preserves_not_has_disc_negated:
  assumes n: "normalized_nnf_match m" and wf_disc_sel: "wf_disc_sel (disc,sel) C"
  and negate_f: "has_disc_negated disc False m  pts. ¬ has_disc_negated disc2 False (negate_f C pts)"
  and no_disc: "¬ has_disc_negated disc2 False m"
  shows  "¬ has_disc_negated disc2 False (rewrite_negated_primitives (disc,sel) C negate_f m)"
    apply(simp add: rewrite_negated_primitives_def)
    apply(case_tac "primitive_extractor (disc,sel) m", rename_tac spts rst)
    apply(simp)
    apply(frule primitive_extractor_correct(3)[OF n wf_disc_sel])
    apply(frule primitive_extractor_correct(8)[OF n wf_disc_sel])
    apply(intro conjI impI)
       using no_disc apply blast
      apply(rule andfold_MatchExp_not_disc_negatedI)
      apply(simp add: negate_f; fail)
     using andfold_MatchExp_not_disc_negated_mapMatch apply blast
    apply(drule primitive_extractor_correct(6)[OF n wf_disc_sel, where neg=False])
    using no_disc by blast

  lemma rewrite_negated_primitives_normalized_preserves_unrelated_helper:
    assumes wf_disc_sel: "wf_disc_sel (disc, sel) C"
    and disc: "a. ¬ disc2 (C a)"
    and disc_p: "(a. ¬ disc2 (Prot a))  ¬ has_disc_negated disc False m" (*either we do not disc on protocol or the is no negated port*)
    shows "normalized_nnf_match m 
         normalized_n_primitive (disc2, sel2) f m 
         a  set (normalize_match (rewrite_negated_primitives (disc, sel) C l4_ports_negate_one m)) 
         normalized_n_primitive (disc2, sel2) f  a"
    proof -
      have helper_a_normalized: "a  MatchAnd x ` (xset spts. MatchAnd x ` set (normalize_match rst)) 
        normalized_n_primitive (disc, sel) f x 
        (s  set spts. normalized_n_primitive (disc, sel) f s) 
        normalized_n_primitive (disc, sel) f rst 
             normalized_n_primitive (disc, sel) f a"
        for a x spts rst f disc and sel::"'a common_primitive  'b"
        apply(subgoal_tac " s r. a = MatchAnd x (MatchAnd s r)  s  set spts  r  set (normalize_match rst)")
         prefer 2
         apply blast
        apply(elim exE conjE, rename_tac s r)
        apply(simp)
        using normalize_match_preserves_normalized_n_primitive by blast

    show "normalized_nnf_match m 
         normalized_n_primitive (disc2, sel2) f m 
         a  set (normalize_match (rewrite_negated_primitives (disc, sel) C l4_ports_negate_one m)) 
         normalized_n_primitive (disc2, sel2) f  a" 
    apply(case_tac "¬ has_disc_negated disc False m")
     subgoal
     using rewrite_negated_primitives_normalized_no_modification[OF wf_disc_sel] by blast
    apply(simp add: rewrite_negated_primitives_def)
    apply(case_tac "primitive_extractor (disc, sel) m", rename_tac spts rst)
    apply(simp)
    apply(subgoal_tac "normalized_n_primitive (disc2, sel2) f rst")
     prefer 2 subgoal for spts rst
     apply(drule primitive_extractor_correct(5)[OF _ wf_disc_sel, where P="f"])
      apply blast
     by(simp)
    apply(insert disc_p, simp)
    apply(drule(1) primitive_extractor_correct(8)[OF _ wf_disc_sel])
    apply(simp)
    apply(elim bexE)
    apply(erule helper_a_normalized)
      subgoal for spts
      apply(rule_tac pts="(getNeg spts)" in negated_normalized_folded_ports_normalized_n_primitive[where C=C])
        using disc apply(simp; fail)
       using disc_p primitive_extractor_correct(8)[OF _ wf_disc_sel] apply blast
      by simp
     subgoal for x
     apply(intro ballI)
     apply(rule andfold_MatchExp_normalized_normalized_n_primitive_single[where C=C])
       using disc disc_p by(simp)+
    by blast
  qed


  definition rewrite_negated_src_ports
    :: "'i::len common_primitive match_expr  'i common_primitive match_expr" where
    "rewrite_negated_src_ports m 
          rewrite_negated_primitives (is_Src_Ports, src_ports_sel) Src_Ports l4_ports_negate_one m"

  definition rewrite_negated_dst_ports
    :: "'i::len common_primitive match_expr  'i common_primitive match_expr" where
    "rewrite_negated_dst_ports m 
          rewrite_negated_primitives (is_Dst_Ports, dst_ports_sel) Dst_Ports l4_ports_negate_one m"

  value "rewrite_negated_src_ports (MatchAnd (Match (Dst (IpAddrNetmask (ipv4addr_of_dotdecimal (127, 0, 0, 0)) 8)))
                   (MatchAnd (Match (Prot (Proto TCP)))
                        (MatchNot (Match (Src_Ports (L4Ports UDP [(80,80)]))))
                 ))"
  value "rewrite_negated_src_ports (MatchAnd (Match (Dst (IpAddrNetmask (ipv4addr_of_dotdecimal (127, 0, 0, 0)) 8)))
                   (MatchAnd (Match (Prot (Proto TCP)))
                        (MatchNot (Match (Extra ''foobar'')))
                 ))"

  lemma rewrite_negated_src_ports:
  assumes generic: "primitive_matcher_generic β"  and n: "normalized_nnf_match m"
  shows "matches (β, α) (rewrite_negated_src_ports m) a p  matches (β, α) m a p"
  apply(simp add: rewrite_negated_src_ports_def)
  apply(rule rewrite_negated_primitives)
    by(simp add: l4_ports_negate_one[OF generic] n wf_disc_sel_common_primitive(1))+
 
  lemma rewrite_negated_dst_ports:
  assumes generic: "primitive_matcher_generic β"  and n: "normalized_nnf_match m"
  shows "matches (β, α) (rewrite_negated_dst_ports m) a p  matches (β, α) m a p"
  apply(simp add: rewrite_negated_dst_ports_def)
  apply(rule rewrite_negated_primitives)
    by(simp add: l4_ports_negate_one[OF generic] n wf_disc_sel_common_primitive(2))+


  lemma rewrite_negated_src_ports_not_has_disc_negated:
  assumes n: "normalized_nnf_match m"
  shows  "¬ has_disc_negated is_Src_Ports False (rewrite_negated_src_ports m)"
    apply(simp add: rewrite_negated_src_ports_def)
    apply(rule rewrite_negated_primitives_not_has_disc_negated)
      by(simp add: n wf_disc_sel_common_primitive(1) l4_ports_negate_one_not_has_disc_negated)+
    
  lemma rewrite_negated_dst_ports_not_has_disc_negated:
  assumes n: "normalized_nnf_match m"
  shows  "¬ has_disc_negated is_Dst_Ports False (rewrite_negated_dst_ports m)"
    apply(simp add: rewrite_negated_dst_ports_def)
    apply(rule rewrite_negated_primitives_not_has_disc_negated)
      by(simp add: n wf_disc_sel_common_primitive(2) l4_ports_negate_one_not_has_disc_negated)+
    

  lemma "¬ has_disc_negated disc t m  m'  set (normalize_match m). ¬ has_disc_negated disc t m'"
    by(fact i_m_giving_this_a_funny_name_so_i_can_thank_my_future_me_when_sledgehammer_will_find_this_one_day)

  corollary normalize_rewrite_negated_src_ports_not_has_disc_negated:
  assumes n: "normalized_nnf_match m"
  shows "m'  set (normalize_match (rewrite_negated_src_ports m)). ¬ has_disc_negated is_Src_Ports False m'"
    apply(rule i_m_giving_this_a_funny_name_so_i_can_thank_my_future_me_when_sledgehammer_will_find_this_one_day)
    apply(rule rewrite_negated_src_ports_not_has_disc_negated)
    using n by simp



subsection‹Normalizing Positive Matches on Ports›
(*now normalizing the match expression which does not have negated ports*)

(*creates a disjunction where all interval lists only have one element*)
  fun singletonize_L4Ports :: "ipt_l4_ports  ipt_l4_ports list" where
    "singletonize_L4Ports (L4Ports proto pts) = map (λp. L4Ports proto [p]) pts"

  lemma singletonize_L4Ports_src: assumes generic: "primitive_matcher_generic β"
   shows "match_list (β, α) (map (Match  Src_Ports) (singletonize_L4Ports pts)) a p  
    matches (β, α) (Match (Src_Ports pts)) a p"
    apply(cases pts)
    apply(simp add: match_list_matches primitive_matcher_generic.Ports_single[OF generic])
    apply(simp add: ports_to_set)
    by auto

  lemma singletonize_L4Ports_dst: assumes generic: "primitive_matcher_generic β"
   shows "match_list (β, α) (map (Match  Dst_Ports) (singletonize_L4Ports pts)) a p  
    matches (β, α) (Match (Dst_Ports pts)) a p"
    apply(cases pts)
    apply(simp add: match_list_matches primitive_matcher_generic.Ports_single[OF generic])
    apply(simp add: ports_to_set)
    by auto

  lemma singletonize_L4Ports_normalized_generic:
    assumes wf_disc_sel: "wf_disc_sel (disc,sel) C"
    and "m'  (λspt. Match (C spt)) ` set (singletonize_L4Ports pt)"
    shows "normalized_n_primitive (disc, sel) (case_ipt_l4_ports (λx pts. length pts  1))  m'"
    using assms
    apply(case_tac pt)
    apply(simp)
    apply(induction m')
        by(auto simp: wf_disc_sel.simps)

  lemma singletonize_L4Ports_normalized_src_ports:
    "m'  (λspt. Match (Src_Ports spt)) ` set (singletonize_L4Ports pt)  normalized_src_ports m'"
    apply(simp add: normalized_src_ports_def2)
    using singletonize_L4Ports_normalized_generic[OF wf_disc_sel_common_primitive(1)] by blast

  lemma singletonize_L4Ports_normalized_dst_ports:
    "m'  (λspt. Match (Dst_Ports spt)) ` set (singletonize_L4Ports pt)  normalized_dst_ports m'"
    apply(simp add: normalized_dst_ports_def2)
    using singletonize_L4Ports_normalized_generic[OF wf_disc_sel_common_primitive(2)] by blast

  declare singletonize_L4Ports.simps[simp del]


  lemma normalized_ports_singletonize_combine_rst:
    assumes wf_disc_sel: "wf_disc_sel (disc,sel) C"
    shows "normalized_n_primitive (disc, sel) (case_ipt_l4_ports (λx pts. length pts  1)) rst 
    m'  (λspt. MatchAnd (Match (C spt)) rst) ` set (singletonize_L4Ports pt) 
    normalized_n_primitive (disc, sel) (case_ipt_l4_ports (λx pts. length pts  1)) m'"
   apply simp
   apply(rule normalized_n_primitive_MatchAnd_combine_map)
     apply(simp_all)
   using singletonize_L4Ports_normalized_generic[OF wf_disc_sel] by fastforce


  text‹Normalizing match expressions such that at most one port will exist in it.
       Returns a list of match expressions (splits one firewall rule into several rules).›
  definition normalize_positive_ports_step
    :: "(('i::len common_primitive  bool) × ('i common_primitive  ipt_l4_ports))  
       (ipt_l4_ports  'i common_primitive) 
       'i common_primitive match_expr  'i common_primitive match_expr list" where 
    "normalize_positive_ports_step disc_sel C m 
        let (spts, rst) = primitive_extractor disc_sel m in
        case (getPos spts, getNeg spts)
          of (pspts, [])  (case l4_ports_compress pspts of CannotMatch  []
                                                          |  MatchesAll  [rst]
                                                          |  MatchExpr m  map (λspt. (MatchAnd (Match (C spt)) rst)) (singletonize_L4Ports m)
                            )
          |  (_, _)  undefined"


  lemma normalize_positive_ports_step_nnf:
    assumes n: "normalized_nnf_match m" and wf_disc_sel: "wf_disc_sel (disc,sel) C"
    and noneg: "¬ has_disc_negated disc False m"
    shows "m'  set (normalize_positive_ports_step (disc,sel) C m)  normalized_nnf_match m'"
    apply(simp add: normalize_positive_ports_step_def)
    apply(elim exE conjE, rename_tac rst spts)
    apply(drule sym) (*switch primitive_extrartor = *)
    apply(frule primitive_extractor_correct(2)[OF n wf_disc_sel])
    apply(subgoal_tac "getNeg spts = []") (*duplication above*)
     prefer 2 subgoal
     apply(drule primitive_extractor_correct(8)[OF n wf_disc_sel])
      using noneg by simp+
    apply(simp split: match_compress.split_asm)
    by fastforce

  lemma normalize_positive_ports_step_normalized_n_primitive: 
    assumes n: "normalized_nnf_match m"  and wf_disc_sel: "wf_disc_sel (disc,sel) C"
    and noneg: "¬ has_disc_negated disc False m"
    shows "m'  set (normalize_positive_ports_step (disc,sel) C m). 
            normalized_n_primitive (disc,sel) (λps. case ps of L4Ports _ pts  length pts  1) m'"
  unfolding normalize_positive_ports_step_def
    apply(intro ballI, rename_tac m')
    apply(simp)
    apply(elim exE conjE, rename_tac rst spts)
    apply(drule sym) (*switch primitive_extrartor = *)
    apply(frule primitive_extractor_correct(2)[OF n wf_disc_sel])
    apply(frule primitive_extractor_correct(3)[OF n wf_disc_sel])
    apply(subgoal_tac "getNeg spts = []") (*duplication above*)
     prefer 2 subgoal
     apply(drule primitive_extractor_correct(8)[OF n wf_disc_sel])
      using noneg by simp+
    apply(subgoal_tac "normalized_n_primitive (disc,sel) (λps. case ps of L4Ports _ pts  length pts  1) rst")
     prefer 2 subgoal
     by(drule(2) normalized_n_primitive_if_no_primitive)
    apply(simp split: match_compress.split_asm)
    using normalized_ports_singletonize_combine_rst[OF wf_disc_sel] by blast

  definition normalize_positive_src_ports :: "'i::len common_primitive match_expr  'i common_primitive match_expr list" where
    "normalize_positive_src_ports = normalize_positive_ports_step (is_Src_Ports, src_ports_sel) Src_Ports"  
  definition normalize_positive_dst_ports :: "'i::len common_primitive match_expr  'i common_primitive match_expr list" where
    "normalize_positive_dst_ports = normalize_positive_ports_step (is_Dst_Ports, dst_ports_sel) Dst_Ports"

  (*TODO: into next lemmas?*)
  lemma noNeg_mapNegPos_helper: "getNeg ls = [] 
           map (Pos  C) (getPos ls) = NegPos_map C ls"
    by(induction ls rule: getPos.induct) simp+

  lemma normalize_positive_src_ports:
    assumes generic: "primitive_matcher_generic β"
    and n: "normalized_nnf_match m"
    and noneg: "¬ has_disc_negated is_Src_Ports False m"
    shows
        "match_list (β, α) (normalize_positive_src_ports m) a p  matches (β, α) m a p"
    apply(simp add: normalize_positive_src_ports_def normalize_positive_ports_step_def)
    apply(case_tac "primitive_extractor (is_Src_Ports, src_ports_sel) m", rename_tac spts rst)
    apply(simp)
    apply(subgoal_tac "getNeg spts = []") (*needs assumption for this step *)
     prefer 2 subgoal
     apply(drule primitive_extractor_correct(8)[OF n wf_disc_sel_common_primitive(1)])
      using noneg by simp+
    apply(simp)
    apply(drule primitive_extractor_correct(1)[OF n wf_disc_sel_common_primitive(1), where γ="(β, α)" and a=a and p=p])
    apply(case_tac "l4_ports_compress (getPos spts)")
       apply(simp)
       apply(drule raw_ports_compress_src_CannotMatch[OF generic, where α=α and a=a and p=p])
       apply(simp add: noNeg_mapNegPos_helper; fail)
      apply(simp)
      apply(drule raw_ports_compress_MatchesAll[OF generic, where α=α and a=a and p=p])
      apply(simp add: noNeg_mapNegPos_helper; fail)
     apply(simp add: bunch_of_lemmata_about_matches)
     apply(drule raw_ports_compress_src_MatchExpr[OF generic, where α=α and a=a and p=p])
     apply(insert singletonize_L4Ports_src[OF generic, where α=α and a=a and p=p])
     apply(simp add: match_list_matches)
     apply(simp add: bunch_of_lemmata_about_matches)
     apply(simp add: noNeg_mapNegPos_helper; fail)
    done

  (*copy & paste, TODO generalize*)
  lemma normalize_positive_dst_ports:
    assumes generic: "primitive_matcher_generic β"
    and n: "normalized_nnf_match m"
    and noneg: "¬ has_disc_negated is_Dst_Ports False m"
    shows "match_list (β, α) (normalize_positive_dst_ports m) a p  matches (β, α) m a p"
    apply(simp add: normalize_positive_dst_ports_def normalize_positive_ports_step_def)
    apply(case_tac "primitive_extractor (is_Dst_Ports, dst_ports_sel) m", rename_tac spts rst)
    apply(simp)
    apply(subgoal_tac "getNeg spts = []") (*needs assumption for this step *)
     prefer 2 subgoal
     apply(drule primitive_extractor_correct(8)[OF n wf_disc_sel_common_primitive(2)])
      using noneg by simp+
    apply(simp)
    apply(drule primitive_extractor_correct(1)[OF n wf_disc_sel_common_primitive(2), where γ="(β, α)" and a=a and p=p])
    apply(case_tac "l4_ports_compress (getPos spts)")
       apply(simp)
       apply(drule raw_ports_compress_dst_CannotMatch[OF generic, where α=α and a=a and p=p])
       apply(simp add: noNeg_mapNegPos_helper; fail)
      apply(simp)
      apply(drule raw_ports_compress_MatchesAll(2)[OF generic, where α=α and a=a and p=p])
      apply(simp add: noNeg_mapNegPos_helper; fail)
     apply(simp add: bunch_of_lemmata_about_matches)
     apply(drule raw_ports_compress_dst_MatchExpr[OF generic, where α=α and a=a and p=p])
     apply(insert singletonize_L4Ports_dst[OF generic, where α=α and a=a and p=p])
     apply(simp add: match_list_matches)
     apply(simp add: bunch_of_lemmata_about_matches)
     apply(simp add: noNeg_mapNegPos_helper; fail)
    done    

  lemma normalize_positive_src_ports_nnf:
    assumes n: "normalized_nnf_match m"
    and noneg: "¬ has_disc_negated is_Src_Ports False m"
    shows "m'  set (normalize_positive_src_ports m)  normalized_nnf_match m'"
    apply(rule normalize_positive_ports_step_nnf[OF n wf_disc_sel_common_primitive(1) noneg])
    by(simp add: normalize_positive_src_ports_def)
  lemma normalize_positive_dst_ports_nnf:
    assumes n: "normalized_nnf_match m"
    and noneg: "¬ has_disc_negated is_Dst_Ports False m"
    shows "m'  set (normalize_positive_dst_ports m)  normalized_nnf_match m'"
    apply(rule normalize_positive_ports_step_nnf[OF n wf_disc_sel_common_primitive(2) noneg])
    by(simp add: normalize_positive_dst_ports_def)


  lemma normalize_positive_src_ports_normalized_n_primitive: 
    assumes n: "normalized_nnf_match m"
    and noneg: "¬ has_disc_negated is_Src_Ports False m"
    shows "m'  set (normalize_positive_src_ports m). normalized_src_ports m'"
    unfolding normalized_src_ports_def2
    unfolding normalize_positive_src_ports_def
    using normalize_positive_ports_step_normalized_n_primitive[OF n wf_disc_sel_common_primitive(1) noneg] by blast

  lemma normalize_positive_dst_ports_normalized_n_primitive: 
    assumes n: "normalized_nnf_match m"
    and noneg: "¬ has_disc_negated is_Dst_Ports False m"
    shows "m'  set (normalize_positive_dst_ports m). normalized_dst_ports m'"
    unfolding normalized_dst_ports_def2
    unfolding normalize_positive_dst_ports_def
    using normalize_positive_ports_step_normalized_n_primitive[OF n wf_disc_sel_common_primitive(2) noneg] by blast
   


subsection‹Complete Normalization›


  definition normalize_ports_generic
    :: "('i common_primitive match_expr  'i common_primitive match_expr list) 
        ('i common_primitive match_expr  'i common_primitive match_expr) 
       'i::len common_primitive match_expr  'i common_primitive match_expr list"
  where
    "normalize_ports_generic normalize_pos rewrite_neg m = concat (map normalize_pos (normalize_match (rewrite_neg m)))"  



  lemma normalize_ports_generic_nnf:
    assumes n: "normalized_nnf_match m"
    and inset: "m'  set (normalize_ports_generic normalize_pos rewrite_neg m)"
    and noNeg: "¬ has_disc_negated disc False (rewrite_neg m)"
    and normalize_nnf_pos: "m m'.
        normalized_nnf_match  m  ¬ has_disc_negated disc False m 
          m'  set (normalize_pos m)  normalized_nnf_match m'"
    shows "normalized_nnf_match m'"
    using inset apply(simp add: normalize_ports_generic_def)
    apply(elim bexE, rename_tac a)
    apply(subgoal_tac "normalized_nnf_match a")
     prefer 2
     using normalized_nnf_match_normalize_match apply blast
    apply(erule normalize_nnf_pos, simp_all)
    apply(rule not_has_disc_normalize_match)
     using noNeg n by blast+

  lemma normalize_ports_generic:
    assumes n: "normalized_nnf_match m"
    and normalize_pos: "m. normalized_nnf_match m  ¬ has_disc_negated disc False m 
                          match_list γ (normalize_pos m) a p  matches γ m a p"
    and rewrite_neg: "m. normalized_nnf_match m 
                          matches γ (rewrite_neg m) a p = matches γ m a p"
    and noNeg: "m. normalized_nnf_match m  ¬ has_disc_negated disc False (rewrite_neg m)"
    shows
        "match_list γ (normalize_ports_generic normalize_pos rewrite_neg m) a p  matches γ m a p"
    unfolding normalize_ports_generic_def
    proof
      have 1: "ls  set (normalize_match (rewrite_neg m)) 
          match_list γ (normalize_pos ls) a p  normalized_nnf_match ls  matches γ m a p"
      for ls
      apply(subst(asm) normalize_pos)
        subgoal using normalized_nnf_match_normalize_match by blast
       subgoal apply(rule_tac m="rewrite_neg m" in not_has_disc_normalize_match)
        using noNeg n apply blast
       by blast
      apply(subgoal_tac "matches γ (rewrite_neg m) a p")
       using rewrite_neg[OF n] apply blast
      using in_normalized_matches[where γ=γ and a=a and p=p] by blast

      show "match_list γ (concat (map normalize_pos (normalize_match (rewrite_neg m)))) a p  matches γ m a p"
      apply(simp add: match_list_concat)
      apply(clarify, rename_tac ls)
      apply(subgoal_tac "normalized_nnf_match ls")
       using 1 apply(simp; fail)
      using normalized_nnf_match_normalize_match by blast
    next
      have 1: "ls  set (normalize_match (rewrite_neg m)) 
          matches γ ls a p 
          normalized_nnf_match ls 
          match_list γ (concat (map normalize_pos (normalize_match (rewrite_neg m)))) a p" for ls
       apply(simp add: match_list_concat)
       apply(rule_tac x=ls in bexI)
        prefer 2 apply(simp; fail)
       apply(subst normalize_pos)
         apply(simp_all)
       apply(rule_tac m="rewrite_neg m" in not_has_disc_normalize_match)
        using noNeg n apply blast
       by blast
      show "matches γ m a p  match_list γ (concat (map normalize_pos (normalize_match (rewrite_neg m)))) a p"
       apply(subst(asm) rewrite_neg[OF n, symmetric])
       apply(subst(asm) matches_to_match_list_normalize)
       apply(subst(asm) match_list_matches)
       apply(elim bexE, rename_tac ls)
       apply(subgoal_tac "normalized_nnf_match ls")
        using 1 apply blast
       using normalized_nnf_match_normalize_match by blast
    qed


  lemma normalize_ports_generic_normalized_n_primitive:
    assumes n: "normalized_nnf_match m"  and wf_disc_sel: "wf_disc_sel (disc,sel) C"
    and noNeg: "m. normalized_nnf_match m  ¬ has_disc_negated disc False (rewrite_neg m)"
    and normalize_nnf_pos: "m m'.
        normalized_nnf_match  m  ¬ has_disc_negated disc False m 
          m'  set (normalize_pos m)  normalized_nnf_match m'"
    and normalize_pos: "m m'.
        normalized_nnf_match m   ¬ has_disc_negated disc False m  
          m'set (normalize_pos m).
                 normalized_n_primitive (disc,sel) (λps. case ps of L4Ports _ pts  length pts  1) m'"
    shows "m'  set (normalize_ports_generic normalize_pos rewrite_neg m). 
             normalized_n_primitive (disc,sel) (λps. case ps of L4Ports _ pts  length pts  1) m'"
  unfolding normalize_ports_generic_def
  apply(intro ballI, rename_tac m')
  apply(simp)
  apply(elim bexE, rename_tac a)
  apply(subgoal_tac "normalized_nnf_match a")
   prefer 2
   using normalized_nnf_match_normalize_match apply blast
  apply(subgoal_tac "¬ has_disc_negated disc False a")
   prefer 2
   subgoal for ls (*TODO: same is already above!*)
    apply(rule_tac m="rewrite_neg m" in not_has_disc_normalize_match)
     using noNeg n apply blast
    by blast
  apply(subgoal_tac "normalized_nnf_match m'")
   prefer 2
   using normalize_nnf_pos apply blast
  using normalize_pos by blast

  lemma normalize_ports_generic_normalize_positive_ports_step_erule:
    assumes n: "normalized_nnf_match m"
      and wf_disc_sel: "wf_disc_sel (disc, sel) C"
      and noProt: "a. ¬ disc (Prot a)" (*disc is src_ports or dst_ports anyway*)
      and P: "P (disc2, sel2) m"
      and P1: "a. normalized_nnf_match a  
                a  set (normalize_match (rewrite_negated_primitives (disc, sel) C l4_ports_negate_one m)) 
                P (disc2, sel2) a"
      and P2: "a dpts rst. normalized_nnf_match a  
                    primitive_extractor (disc, sel) a = (dpts, rst) 
                    getNeg dpts = []  P (disc2, sel2) a  P (disc2, sel2) rst"
      and P3: " a spt rst. P (disc2, sel2) rst  P (disc2, sel2) (MatchAnd (Match (C spt)) rst)"
    shows "m'  set (normalize_ports_generic (normalize_positive_ports_step (disc, sel) C) (rewrite_negated_primitives (disc, sel) C l4_ports_negate_one) m) 
          P (disc2, sel2) m'"
    using P apply(simp add: normalize_ports_generic_def)
    apply(elim bexE, rename_tac a)
    apply(subgoal_tac "normalized_nnf_match a")
     prefer 2 using normalized_nnf_match_normalize_match apply blast
    apply(simp add: normalize_positive_ports_step_def)
    apply(elim exE conjE, rename_tac rst dpts)
    apply(drule sym) (*primitive extractor*)
    apply(subgoal_tac "getNeg dpts = []")
     prefer 2 subgoal for a rst dpts
     apply(erule iffD1[OF primitive_extractor_correct(8)[OF _ wf_disc_sel]])
      apply(simp; fail)
     apply(rule not_has_disc_normalize_match)
      apply(simp_all)
     apply(rule rewrite_negated_primitives_not_has_disc_negated[OF n wf_disc_sel])
     apply(intro allI)
     apply(rule l4_ports_negate_one_not_has_disc_negated_generic)
     by(simp add: noProt)
    apply(subgoal_tac "P (disc2, sel2) a")
     prefer 2 subgoal
     apply(rule P1)
     by(simp)
    apply(frule_tac a=a in P2)
      apply blast+
    apply(simp split: match_compress.split_asm)
    using P3 by auto
  
  (*disc is is_Src_Ports or is_Dst_Ports*)
  lemma normalize_ports_generic_preserves_normalized_n_primitive:
    assumes n: "normalized_nnf_match m"
      and wf_disc_sel: "wf_disc_sel (disc, sel) C"
      and noProt: "a. ¬ disc (Prot a)" (*disc is src_ports or dst_ports anyway*)
      and disc2_noC: "a. ¬ disc2 (C a)"
      and disc2_noProt: "(a. ¬ disc2 (Prot a))  ¬ has_disc_negated disc False m"
    shows "m'  set (normalize_ports_generic (normalize_positive_ports_step (disc, sel) C) (rewrite_negated_primitives (disc, sel) C l4_ports_negate_one) m) 
         normalized_n_primitive (disc2, sel2) f m 
          normalized_n_primitive (disc2, sel2) f m'"
    thm normalize_ports_generic_normalize_positive_ports_step_erule
    apply(rule normalize_ports_generic_normalize_positive_ports_step_erule[OF n wf_disc_sel noProt])
        apply(simp_all add: disc2_noC disc2_noProt)
     apply(rule rewrite_negated_primitives_normalized_preserves_unrelated_helper[OF wf_disc_sel _ _ n])
        apply(simp_all add: disc2_noC disc2_noProt)
    apply(frule_tac m=a in primitive_extractor_correct(5)[OF _ wf_disc_sel, where P=f])
     by blast+
  
  lemma normalize_ports_generic_preserves_normalized_not_has_disc:
    assumes n: "normalized_nnf_match m" and nodisc: "¬ has_disc disc2 m"
      and wf_disc_sel: "wf_disc_sel (disc, sel) C"
      and noProt: "a. ¬ disc (Prot a)" (*disc is src_ports or dst_ports anyway*)
      and disc2_noC: "a. ¬ disc2 (C a)"
      and disc2_noProt: "(a. ¬ disc2 (Prot a))  ¬ has_disc_negated disc False m"
     shows "m' set (normalize_ports_generic (normalize_positive_ports_step (disc, sel) C) (rewrite_negated_primitives (disc, sel) C l4_ports_negate_one) m)
       ¬ has_disc disc2 m'"
    apply(rule normalize_ports_generic_normalize_positive_ports_step_erule[OF n wf_disc_sel noProt])
        apply(simp_all add: disc2_noC disc2_noProt nodisc)
     subgoal for a
     thm normalize_match_preserves_nodisc
     apply(rule_tac m="rewrite_negated_primitives (disc, sel) C l4_ports_negate_one m" in normalize_match_preserves_nodisc)
      apply(simp_all)
     apply(insert disc2_noProt)
     apply(elim disjE)
      thm rewrite_negated_primitives_not_has_disc[of _ disc2]
      subgoal apply(rule rewrite_negated_primitives_not_has_disc[OF n wf_disc_sel nodisc _ disc2_noC])
      using l4_ports_negate_one_nodisc[OF disc2_noC] by blast
     using rewrite_negated_primitives_preserves_not_has_disc[OF n wf_disc_sel nodisc _ disc2_noC] by blast
    apply(frule_tac m=a in primitive_extractor_correct(4)[OF _ wf_disc_sel])
     by blast+

  lemma normalize_ports_generic_preserves_normalized_not_has_disc_negated:
    assumes n: "normalized_nnf_match m" and nodisc: "¬ has_disc_negated disc2 False m"
      and wf_disc_sel: "wf_disc_sel (disc, sel) C"
      and noProt: "a. ¬ disc (Prot a)" (*disc is src_ports or dst_ports anyway*)
      and disc2_noProt: "(a. ¬ disc2 (Prot a))  ¬ has_disc_negated disc False m"
     shows "m' set (normalize_ports_generic (normalize_positive_ports_step (disc, sel) C) (rewrite_negated_primitives (disc, sel) C l4_ports_negate_one) m)
       ¬ has_disc_negated disc2 False m'"
    apply(rule normalize_ports_generic_normalize_positive_ports_step_erule[OF n wf_disc_sel noProt])
        apply(simp_all add: disc2_noProt nodisc)
     subgoal for a
     apply(rule_tac m="rewrite_negated_primitives (disc, sel) C l4_ports_negate_one m" in not_has_disc_normalize_match)
      apply(simp_all)
     apply(rule rewrite_negated_primitives_preserves_not_has_disc_negated[OF n wf_disc_sel ])
      using disc2_noProt l4_ports_negate_one_not_has_disc_negated_generic apply blast
     using nodisc by blast
    subgoal for a dpts rst
    apply(frule_tac m=a and as=dpts and ms=rst and neg=False in primitive_extractor_correct(6)[OF _ wf_disc_sel])
     by blast+
   done

  definition normalize_src_ports
    :: "'i::len common_primitive match_expr  'i common_primitive match_expr list"
  where
    "normalize_src_ports m = normalize_ports_generic normalize_positive_src_ports rewrite_negated_src_ports m" 

  definition normalize_dst_ports
    :: "'i::len common_primitive match_expr  'i common_primitive match_expr list"
  where
    "normalize_dst_ports m = normalize_ports_generic normalize_positive_dst_ports rewrite_negated_dst_ports m"

  lemma normalize_src_ports:
    assumes generic: "primitive_matcher_generic β"
    and n: "normalized_nnf_match m"
    shows "match_list (β, α) (normalize_src_ports m) a p  matches (β, α) m a p"
     apply(simp add: normalize_src_ports_def)
     apply(rule normalize_ports_generic[OF n])
       using normalize_positive_src_ports[OF generic]
             rewrite_negated_src_ports[OF generic, where α=α and a=a and p=p]
             rewrite_negated_src_ports_not_has_disc_negated by blast+

  lemma normalize_dst_ports:
    assumes generic: "primitive_matcher_generic β"
    and n: "normalized_nnf_match m"
    shows "match_list (β, α) (normalize_dst_ports m) a p  matches (β, α) m a p"
     apply(simp add: normalize_dst_ports_def)
     apply(rule normalize_ports_generic[OF n])
       using normalize_positive_dst_ports[OF generic]
             rewrite_negated_dst_ports[OF generic, where α=α and a=a and p=p]
             rewrite_negated_dst_ports_not_has_disc_negated by blast+

  lemma normalize_src_ports_normalized_n_primitive:
    assumes n:"normalized_nnf_match m"
    shows "m'  set (normalize_src_ports m). normalized_src_ports m'"
  unfolding normalize_src_ports_def normalized_src_ports_def2
  apply(rule normalize_ports_generic_normalized_n_primitive[OF n wf_disc_sel_common_primitive(1)])
    using rewrite_negated_src_ports_not_has_disc_negated apply blast
   using normalize_positive_src_ports_nnf apply blast
  unfolding normalized_src_ports_def2[symmetric]
  using normalize_positive_src_ports_normalized_n_primitive by blast

  lemma normalize_dst_ports_normalized_n_primitive:
    assumes n: "normalized_nnf_match m"
    shows "m'  set (normalize_dst_ports m). normalized_dst_ports m'"
  unfolding normalize_dst_ports_def normalized_dst_ports_def2
  apply(rule normalize_ports_generic_normalized_n_primitive[OF n wf_disc_sel_common_primitive(2)])
    using rewrite_negated_dst_ports_not_has_disc_negated apply blast
   using normalize_positive_dst_ports_nnf apply blast
  unfolding normalized_dst_ports_def2[symmetric]
  using normalize_positive_dst_ports_normalized_n_primitive by blast

  lemma normalize_src_ports_nnf:
    assumes n: "normalized_nnf_match m"
    shows "m'  set (normalize_src_ports m)  normalized_nnf_match m'"
    apply(simp add: normalize_src_ports_def)
    apply(erule normalize_ports_generic_nnf[OF n])
     using n rewrite_negated_src_ports_not_has_disc_negated apply blast
    using normalize_positive_src_ports_nnf by blast

  lemma normalize_dst_ports_nnf:
    assumes n: "normalized_nnf_match m"
    shows "m'  set (normalize_dst_ports m)  normalized_nnf_match m'"
    apply(simp add: normalize_dst_ports_def)
    apply(erule normalize_ports_generic_nnf[OF n])
     using n rewrite_negated_dst_ports_not_has_disc_negated apply blast
    using normalize_positive_dst_ports_nnf by blast


  lemma normalize_src_ports_preserves_normalized_n_primitive:
    assumes n: "normalized_nnf_match m"
      and disc2_noC: "a. ¬ disc2 (Src_Ports a)"
      and disc2_noProt: "(a. ¬ disc2 (Prot a))  ¬ has_disc_negated is_Src_Ports False m"
    shows "m'  set (normalize_src_ports m) 
         normalized_n_primitive (disc2, sel2) f  m 
          normalized_n_primitive (disc2, sel2) f m'"
      apply(rule normalize_ports_generic_preserves_normalized_n_primitive[OF n wf_disc_sel_common_primitive(1)])
      by(simp_all add: disc2_noC disc2_noProt normalize_src_ports_def normalize_ports_generic_def
                normalize_positive_src_ports_def rewrite_negated_src_ports_def)
  
  lemma normalize_dst_ports_preserves_normalized_n_primitive:
    assumes n: "normalized_nnf_match m"
      and disc2_noC: "a. ¬ disc2 (Dst_Ports a)"
      and disc2_noProt: "(a. ¬ disc2 (Prot a))  ¬ has_disc_negated is_Dst_Ports False m"
    shows "m'  set (normalize_dst_ports m) 
         normalized_n_primitive (disc2, sel2) f  m 
          normalized_n_primitive (disc2, sel2) f m'"
      apply(rule normalize_ports_generic_preserves_normalized_n_primitive[OF n wf_disc_sel_common_primitive(2)])
      by(simp_all add: disc2_noC disc2_noProt normalize_dst_ports_def normalize_ports_generic_def
                normalize_positive_dst_ports_def rewrite_negated_dst_ports_def)
  
  lemma normalize_src_ports_preserves_normalized_not_has_disc:
    assumes n: "normalized_nnf_match m" and nodisc: "¬ has_disc disc2 m"
      and disc2_noC: "a. ¬ disc2 (Src_Ports a)"
      and disc2_noProt: "(a. ¬ disc2 (Prot a))  ¬ has_disc_negated is_Src_Ports False m"
     shows "m' set (normalize_src_ports m)
       ¬ has_disc disc2 m'"
  apply(rule normalize_ports_generic_preserves_normalized_not_has_disc[OF n nodisc wf_disc_sel_common_primitive(1)])
      apply(simp add: disc2_noC disc2_noProt)+
  by (simp add: normalize_ports_generic_def normalize_positive_src_ports_def normalize_src_ports_def rewrite_negated_src_ports_def)
  
  lemma normalize_dst_ports_preserves_normalized_not_has_disc:
    assumes n: "normalized_nnf_match m" and nodisc: "¬ has_disc disc2 m"
      and disc2_noC: "a. ¬ disc2 (Dst_Ports a)"
      and disc2_noProt: "(a. ¬ disc2 (Prot a))  ¬ has_disc_negated is_Dst_Ports False m"
     shows "m' set (normalize_dst_ports m)
       ¬ has_disc disc2 m'"
  apply(rule normalize_ports_generic_preserves_normalized_not_has_disc[OF n nodisc wf_disc_sel_common_primitive(2)])
      apply(simp add: disc2_noC disc2_noProt)+
  by (simp add: normalize_ports_generic_def normalize_positive_dst_ports_def normalize_dst_ports_def rewrite_negated_dst_ports_def)
  
  lemma normalize_src_ports_preserves_normalized_not_has_disc_negated:
    assumes n: "normalized_nnf_match m" and nodisc: "¬ has_disc_negated disc2 False m"
      and disc2_noProt: "(a. ¬ disc2 (Prot a))  ¬ has_disc_negated is_Src_Ports False m"
     shows "m' set (normalize_src_ports m)
       ¬ has_disc_negated disc2 False m'"
  apply(rule normalize_ports_generic_preserves_normalized_not_has_disc_negated[OF n nodisc wf_disc_sel_common_primitive(1)])
      apply(simp add: disc2_noProt)+
  by (simp add: normalize_ports_generic_def normalize_positive_src_ports_def normalize_src_ports_def rewrite_negated_src_ports_def)
  
  lemma normalize_dst_ports_preserves_normalized_not_has_disc_negated:
    assumes n: "normalized_nnf_match m" and nodisc: "¬ has_disc_negated disc2 False m"
      and disc2_noProt: "(a. ¬ disc2 (Prot a))  ¬ has_disc_negated is_Dst_Ports False m"
     shows "m' set (normalize_dst_ports m)
       ¬ has_disc_negated disc2 False m'"
  apply(rule normalize_ports_generic_preserves_normalized_not_has_disc_negated[OF n nodisc wf_disc_sel_common_primitive(2)])
      apply(simp add: disc2_noProt)+
  by (simp add: normalize_ports_generic_def normalize_positive_dst_ports_def normalize_dst_ports_def rewrite_negated_dst_ports_def)

value[code] "normalize_src_ports
                (MatchAnd (Match (Dst (IpAddrNetmask (ipv4addr_of_dotdecimal (127, 0, 0, 0)) 8)))
                   (MatchAnd (Match (Prot (Proto TCP)))
                        (MatchNot (Match (Src_Ports (L4Ports UDP [(80,80)]))))
                 ))"


lemma "map opt_MatchAny_match_expr (normalize_src_ports
                (MatchAnd (Match (Dst (IpAddrNetmask (ipv4addr_of_dotdecimal (127, 0, 0, 0)) 8)))
                   (MatchAnd (Match (Prot (Proto TCP)))
                        (MatchNot (Match (Src_Ports (L4Ports UDP [(80,80)]))))
                 ))) =
 [MatchAnd (MatchNot (Match (Prot (Proto UDP)))) (MatchAnd (Match (Dst (IpAddrNetmask 0x7F000000 8))) (Match (Prot (Proto TCP)))),
  MatchAnd (Match (Src_Ports (L4Ports UDP [(0, 79)]))) (MatchAnd (Match (Dst (IpAddrNetmask 0x7F000000 8))) (Match (Prot (Proto TCP)))),
  MatchAnd (Match (Src_Ports (L4Ports UDP [(81, 0xFFFF)]))) (MatchAnd (Match (Dst (IpAddrNetmask 0x7F000000 8))) (Match (Prot (Proto TCP))))]" by eval

lemma "map opt_MatchAny_match_expr (normalize_src_ports
                (MatchAnd (Match (Dst (IpAddrNetmask (ipv4addr_of_dotdecimal (127, 0, 0, 0)) 8)))
                   (MatchAnd (Match (Prot (Proto ICMP)))
                     (MatchAnd (Match (Src_Ports (L4Ports TCP [(22,22)])))
                        (MatchNot (Match (Src_Ports (L4Ports UDP [(80,80)]))))
                 ))))
 =
[MatchAnd (Match (Src_Ports (L4Ports TCP [(22, 22)])))
   (MatchAnd (MatchNot (Match (Prot (Proto UDP)))) (MatchAnd (Match (Dst (IpAddrNetmask 0x7F000000 8))) (Match (Prot (Proto ICMP)))))]" by eval


lemma "map opt_MatchAny_match_expr (normalize_src_ports
                (MatchAnd (Match ((Src_Ports (L4Ports UDP [(21,21), (22,22)])) :: 32 common_primitive))
                  (Match (Prot (Proto UDP)))))
  =
[MatchAnd (Match (Src_Ports (L4Ports UDP [(21, 22)]))) (Match (Prot (Proto UDP)))]" by eval


lemma "normalize_match (andfold_MatchExp (map (l4_ports_negate_one C) [])) = [MatchAny]" by(simp)



(*scratch*)
(*TODO: move?*)
  (*TODO: add nnf_normalization directly afterwards?*)
  definition replace_primitive_matchexpr
    :: "(('a  bool) × ('a  'b))  ― ‹disc_sel›
        ('b negation_type  'a match_expr)  ― ‹replace function›
        'a match_expr  'a match_expr" where
    "replace_primitive_matchexpr disc_sel replace_f m 
        let (as, rst) = primitive_extractor disc_sel m
        in if as = [] then m else 
          MatchAnd
            (andfold_MatchExp (map replace_f as))
            rst"


  text‹It does nothing of there is not even a primitive in it›
  lemma replace_primitive_matchexpr_unchanged_if_not_has_disc:
  assumes n: "normalized_nnf_match m"
  and wf_disc_sel: "wf_disc_sel (disc,sel) C" (*any C*)
  and noDisc: "¬ has_disc disc m"
  shows "replace_primitive_matchexpr (disc,sel) replace_f m = m"
    apply(simp add: replace_primitive_matchexpr_def)
    apply(case_tac "primitive_extractor (disc,sel) m", rename_tac spts rst)
    apply(simp)
    apply(frule primitive_extractor_correct(7)[OF n wf_disc_sel])
     using noDisc by blast+

  (*lemma replace_primitive_matchexpr_preserves_not_has_disc:
  assumes n: "normalized_nnf_match m"
  and wf_disc_sel: "wf_disc_sel (disc, sel) C'"
  and nodisc: "¬ has_disc disc2 m"
  and noNeg: "¬ has_disc disc m"
  and disc2_noC: "∀a. ¬ disc2 (C a)"
  shows "¬ has_disc disc2 (replace_primitive_matchexpr (disc, sel) negate_f m)"
    apply(subst replace_primitive_matchexpr_unchanged_if_not_has_disc)
    using n wf_disc_sel noNeg nodisc by(simp)+*)

  lemma replace_primitive_matchexpr:
  assumes n: "normalized_nnf_match m" and wf_disc_sel: "wf_disc_sel disc_sel C"
  and replace_f: "pt. matches γ (replace_f pt) a p 
                        matches γ (negation_type_to_match_expr_f C pt) a p"
  shows "matches γ (replace_primitive_matchexpr disc_sel replace_f m) a p  matches γ m a p"
  proof -
    obtain spts rst where pext: "primitive_extractor disc_sel m = (spts, rst)"
      by(cases "primitive_extractor disc_sel m") simp
    obtain disc sel where disc_sel: "disc_sel = (disc, sel)" by(cases disc_sel) simp
    with wf_disc_sel have wf_disc_sel': "wf_disc_sel (disc, sel) C" by simp
    from disc_sel pext have pext': "primitive_extractor (disc, sel) m = (spts, rst)" by simp
      
    have "matches γ (andfold_MatchExp (map replace_f spts)) a p  matches γ rst a p 
       matches γ m a p"
      apply(subst primitive_extractor_correct(1)[OF n wf_disc_sel' pext', symmetric])
      apply(simp add: andfold_MatchExp_matches)
      apply(simp add: replace_f)
      using alist_and_negation_type_to_match_expr_f_matches by fast
    thus ?thesis by(simp add: replace_primitive_matchexpr_def pext bunch_of_lemmata_about_matches)
  qed

  lemma replace_primitive_matchexpr_replaces_disc:
  assumes n: "normalized_nnf_match m" and wf_disc_sel: "wf_disc_sel (disc, sel) C"
  and replace_f: "a. ¬ has_disc disc (replace_f a)"
  shows "¬ has_disc disc (replace_primitive_matchexpr (disc, sel) replace_f m)"
    apply(simp add: replace_primitive_matchexpr_def)
    apply(case_tac "primitive_extractor (disc,sel) m", rename_tac spts rst)
    apply(simp)
    apply(frule primitive_extractor_correct(3)[OF n wf_disc_sel])
    apply simp
    apply(frule primitive_extractor_correct(7)[OF n wf_disc_sel])
    apply simp
    apply(case_tac "¬ has_disc disc m")
     apply(simp)
    apply(simp)
    apply(frule(1) primitive_extractor_correct(9)[OF n wf_disc_sel])
    apply(simp)
    apply(rule MatchExpr_Fold.andfold_MatchExp_not_discI)
    using replace_f by simp


  lemma replace_primitive_matchexpr_preserves_not_has_disc:
  assumes n: "normalized_nnf_match m" and wf_disc_sel: "wf_disc_sel (disc,sel) C"
  and nodisc: "¬ has_disc disc2 m"
  and replace_f: "has_disc disc m  pts. ¬ has_disc disc2 (replace_f pts)"
  shows "¬ has_disc disc2 (replace_primitive_matchexpr (disc,sel) replace_f m)"
    apply(simp add: replace_primitive_matchexpr_def)
    apply(case_tac "primitive_extractor (disc,sel) m", rename_tac spts rst)
    apply(simp)
    apply(frule primitive_extractor_correct(4)[OF n wf_disc_sel])
    apply(case_tac "¬ has_disc disc m")
     subgoal
     apply(frule primitive_extractor_correct(7)[OF n wf_disc_sel])
     using nodisc by blast
    apply(simp)
    apply(intro conjI impI)
      using nodisc apply(simp; fail)
     apply(rule andfold_MatchExp_not_discI)
     apply(simp add: replace_f; fail)
    using nodisc by blast

  lemma normalize_replace_primitive_matchexpr_preserves_normalized_n_primitive:
    assumes n: "normalized_nnf_match m"
      and wf_disc_sel: "wf_disc_sel (disc, sel) C"
      and replace_f:
        "a m'. m'  set (normalize_match (replace_f a))  normalized_n_primitive (disc2, sel2) f m'"
      and nprim: "normalized_n_primitive (disc2, sel2) f m"
      and m': "m'  set (normalize_match (replace_primitive_matchexpr (disc,sel) replace_f m))"
    shows "normalized_n_primitive (disc2, sel2) f m'"
  proof -
    have x: "x  set (normalize_match (andfold_MatchExp (map replace_f as))) 
          normalized_n_primitive (disc2, sel2) f x" for x as
      apply(rule normalize_andfold_MatchExp_normalized_n_primitive )
       apply(simp_all)
      using replace_f by blast
    from m' show ?thesis
    apply(simp add: replace_primitive_matchexpr_def)
    apply(case_tac "primitive_extractor (disc, sel) m", rename_tac as rst)
    apply(simp split: if_split_asm)
     using normalize_match_preserves_normalized_n_primitive nprim apply blast
    apply(frule_tac P=f in primitive_extractor_correct(5)[OF n wf_disc_sel])
    apply(clarify)
    apply(simp)
    apply(intro conjI)
     prefer 2
     using normalize_match_preserves_normalized_n_primitive nprim apply blast
    by(simp add: x)
  qed

  lemma normalize_replace_primitive_matchexpr_preserves_normalized_not_has_disc:
    assumes n: "normalized_nnf_match m" 
      and wf_disc_sel: "wf_disc_sel (disc, sel) C"
      and nodisc: "¬ has_disc disc2 m"
      and replace_f: "a. ¬ has_disc disc2 (replace_f a)"
     shows "m' set (normalize_match (replace_primitive_matchexpr (disc,sel) replace_f m))
       ¬ has_disc disc2 m'"
    apply(simp add: replace_primitive_matchexpr_def)
    apply(case_tac "primitive_extractor (disc, sel) m", rename_tac as rst)
    apply(simp split: if_split_asm)
     using nodisc normalize_match_preserves_nodisc apply blast
    apply(frule primitive_extractor_correct(4)[OF n wf_disc_sel])
    apply(elim bexE, rename_tac x)
    apply(erule Set.imageE, rename_tac xright) (*m' = MatchAnd x xright*)
    apply(simp)
    apply(intro conjI)
     apply(rule normalize_match_preserves_nodisc, simp_all)
     apply(rule andfold_MatchExp_not_discI, simp)
     using replace_f apply blast
    apply(rule normalize_match_preserves_nodisc)
     apply(insert nodisc)
     by(simp_all)
 
  lemma normalize_replace_primitive_matchexpr_preserves_normalized_not_has_disc_negated:
    assumes n: "normalized_nnf_match m" 
      and wf_disc_sel: "wf_disc_sel (disc, sel) C"
      and nodisc: "¬ has_disc_negated disc2 neg m"
      and replace_f: "a. ¬ has_disc_negated disc2 neg (replace_f a)"
     shows "m' set (normalize_match (replace_primitive_matchexpr (disc,sel) replace_f m))
       ¬ has_disc_negated disc2 neg m'"
    apply(simp add: replace_primitive_matchexpr_def)
    apply(case_tac "primitive_extractor (disc, sel) m", rename_tac as rst)
    apply(simp split: if_split_asm)
     using nodisc not_has_disc_normalize_match apply blast
    apply(frule primitive_extractor_correct(6)[OF n wf_disc_sel, where neg=neg])
    apply(elim bexE, rename_tac x)
    apply(erule Set.imageE, rename_tac xright) (*m' = MatchAnd x xright*)
    apply(simp)
    apply(intro conjI)
     apply(rule not_has_disc_normalize_match, simp_all)
     apply(rule andfold_MatchExp_not_disc_negatedI, simp)
     using replace_f apply blast
    apply(rule not_has_disc_normalize_match)
     apply(insert nodisc)
     by(simp_all)

  corollary normalize_replace_primitive_matchexpr:
    assumes n: "normalized_nnf_match m"
    and replace_f:
      "m. normalized_nnf_match m  
      matches γ (replace_primitive_matchexpr disc_sel replace_f m) a p  matches γ m a p"
    shows
        "match_list γ (normalize_match (replace_primitive_matchexpr disc_sel replace_f m)) a p 
          matches γ m a p"
     by(simp add: matches_to_match_list_normalize[symmetric] replace_f n)


  fun rewrite_MultiportPorts_one
    :: "ipt_l4_ports negation_type 'i::len common_primitive match_expr" where
    "rewrite_MultiportPorts_one (Pos pts) = 
        MatchOr (Match (Src_Ports pts)) (Match (Dst_Ports pts))" |
    "rewrite_MultiportPorts_one (Neg pts) =
        MatchAnd (MatchNot (Match (Src_Ports pts))) (MatchNot (Match (Dst_Ports pts)))"

  lemma rewrite_MultiportPorts_one:
  assumes generic: "primitive_matcher_generic β" and n: "normalized_nnf_match m"
  shows
    "matches (β, α) (replace_primitive_matchexpr (is_MultiportPorts, multiportports_sel) rewrite_MultiportPorts_one m) a p 
      matches (β, α) m a p"
    apply(rule replace_primitive_matchexpr[OF n wf_disc_sel_common_primitive(11)])
    apply(rule allI, rename_tac pt)
    apply(case_tac pt)
     apply(simp add: primitive_matcher_generic.MultiportPorts_single_rewrite_MatchOr[OF generic]; fail)
    apply(simp add: primitive_matcher_generic.MultiportPorts_single_not_rewrite_MatchAnd[OF generic]; fail)
    done

  lemma "a. ¬ disc (Src_Ports a)  a. ¬ disc (Dst_Ports a) 
          normalized_n_primitive (disc, sel) f m 
         m'  set (normalize_match (rewrite_MultiportPorts_one a)).
            normalized_n_primitive (disc, sel) f m'"
    apply(cases a)
     by(simp_all add: MatchOr_def)

  lemma rewrite_MultiportPorts_one_nodisc: 
    "a. ¬ disc (Src_Ports a)  a. ¬ disc (Dst_Ports a) 
          ¬ has_disc disc (rewrite_MultiportPorts_one a)"
    "a. ¬ disc (Src_Ports a)  a. ¬ disc (Dst_Ports a) 
          ¬ has_disc_negated disc neg (rewrite_MultiportPorts_one a)"
    by(cases a, simp_all add: MatchOr_def)+

  definition rewrite_MultiportPorts
    :: "'i::len common_primitive match_expr  'i common_primitive match_expr list" where
    "rewrite_MultiportPorts m  normalize_match 
        (replace_primitive_matchexpr (is_MultiportPorts, multiportports_sel) rewrite_MultiportPorts_one m)"


  lemma rewrite_MultiportPorts:
    assumes generic: "primitive_matcher_generic β"
    and n: "normalized_nnf_match m"
    shows
        "match_list (β, α) (rewrite_MultiportPorts m) a p  matches (β, α) m a p"
    unfolding rewrite_MultiportPorts_def
    apply(intro normalize_replace_primitive_matchexpr[OF n])
    by(simp add: rewrite_MultiportPorts_one[OF generic])

  lemma rewrite_MultiportPorts_normalized_nnf_match:
      "m'  set (rewrite_MultiportPorts m)  normalized_nnf_match m'"
    apply(simp add: rewrite_MultiportPorts_def)
    using normalized_nnf_match_normalize_match by blast


  text‹It does nothing of there is not even the primitive in it›
  lemma rewrite_MultiportPorts_unchanged_if_not_has_disc:
  assumes n: "normalized_nnf_match m"
  and noDisc: "¬ has_disc is_MultiportPorts m"
  shows "rewrite_MultiportPorts m = [m]"
    apply(simp add: rewrite_MultiportPorts_def)
    apply(subst replace_primitive_matchexpr_unchanged_if_not_has_disc[OF n
            wf_disc_sel_common_primitive(11) noDisc])
    using n by(fact normalize_match_already_normalized)
    

  lemma rewrite_MultiportPorts_preserves_normalized_n_primitive:
    assumes n: "normalized_nnf_match m"
      and disc2_noSrcPorts: "a. ¬ disc2 (Src_Ports a)"
      and disc2_noDstPorts: "a. ¬ disc2 (Dst_Ports a)"
    shows "m'  set (rewrite_MultiportPorts m) 
         normalized_n_primitive (disc2, sel2) f  m 
          normalized_n_primitive (disc2, sel2) f m'"
      unfolding rewrite_MultiportPorts_def
      apply(rule normalize_replace_primitive_matchexpr_preserves_normalized_n_primitive[OF
                  n wf_disc_sel_common_primitive(11)])
        apply simp_all
      apply(rename_tac a a')
      apply(case_tac a)
       apply(simp_all add: MatchOr_def)
       using disc2_noSrcPorts disc2_noDstPorts by fastforce+ 

  lemma rewrite_MultiportPorts_preserves_normalized_not_has_disc:
    assumes n: "normalized_nnf_match m" 
      and nodisc: "¬ has_disc disc2 m"
      and disc2_noSrcPorts: "a. ¬ disc2 (Src_Ports a)"
      and disc2_noDstPorts: "a. ¬ disc2 (Dst_Ports a)"
     shows "m' set (rewrite_MultiportPorts m)
       ¬ has_disc disc2 m'"
  apply(simp add: rewrite_MultiportPorts_def)
  apply(rule normalize_replace_primitive_matchexpr_preserves_normalized_not_has_disc[OF n wf_disc_sel_common_primitive(11) nodisc])
   by(simp_all add: rewrite_MultiportPorts_one_nodisc disc2_noSrcPorts disc2_noDstPorts)


  lemma rewrite_MultiportPorts_preserves_normalized_not_has_disc_negated:
    assumes n: "normalized_nnf_match m" 
      and nodisc: "¬ has_disc_negated disc2 neg m"
      and disc2_noSrcPorts: "a. ¬ disc2 (Src_Ports a)"
      and disc2_noDstPorts: "a. ¬ disc2 (Dst_Ports a)"
     shows "m' set (rewrite_MultiportPorts m)
       ¬ has_disc_negated disc2 neg m'"
  apply(simp add: rewrite_MultiportPorts_def)
  apply(rule normalize_replace_primitive_matchexpr_preserves_normalized_not_has_disc_negated[OF n wf_disc_sel_common_primitive(11) nodisc])
   by(simp_all add: rewrite_MultiportPorts_one_nodisc disc2_noSrcPorts disc2_noDstPorts)

  lemma rewrite_MultiportPorts_removes_MultiportsPorts:
    assumes n: "normalized_nnf_match m"
    shows "m'  set (rewrite_MultiportPorts m)  ¬ has_disc is_MultiportPorts m'"
    apply(simp add: rewrite_MultiportPorts_def)
    apply(rule normalize_match_preserves_nodisc)
     apply(simp_all)
    apply(rule replace_primitive_matchexpr_replaces_disc[OF n wf_disc_sel_common_primitive(11)])
    apply(intro allI, rename_tac a)
    by(case_tac a, simp_all add: MatchOr_def)

end

Theory IpAddresses_Normalize

theory IpAddresses_Normalize
imports Common_Primitive_Lemmas
begin


subsection‹Normalizing IP Addresses›
  fun normalized_src_ips :: "'i::len common_primitive match_expr  bool" where
    "normalized_src_ips MatchAny = True" |
    "normalized_src_ips (Match (Src (IpAddrRange _ _))) = False" |
    "normalized_src_ips (Match (Src (IpAddr _))) = False" |
    "normalized_src_ips (Match (Src (IpAddrNetmask _ _))) = True" |
    "normalized_src_ips (Match _) = True" |
    "normalized_src_ips (MatchNot (Match (Src _))) = False" |
    "normalized_src_ips (MatchNot (Match _)) = True" |
    "normalized_src_ips (MatchAnd m1 m2) = (normalized_src_ips m1  normalized_src_ips m2)" |
    "normalized_src_ips (MatchNot (MatchAnd _ _)) = False" |
    "normalized_src_ips (MatchNot (MatchNot _)) = False" |
    "normalized_src_ips (MatchNot (MatchAny)) = True" 
  
  lemma normalized_src_ips_def2: "normalized_src_ips ms = normalized_n_primitive (is_Src, src_sel) normalized_cidr_ip ms"
    by(induction ms rule: normalized_src_ips.induct, simp_all add: normalized_cidr_ip_def)

  fun normalized_dst_ips :: "'i::len common_primitive match_expr  bool" where
    "normalized_dst_ips MatchAny = True" |
    "normalized_dst_ips (Match (Dst (IpAddrRange _ _))) = False" |
    "normalized_dst_ips (Match (Dst (IpAddr _))) = False" |
    "normalized_dst_ips (Match (Dst (IpAddrNetmask _ _))) = True" |
    "normalized_dst_ips (Match _) = True" |
    "normalized_dst_ips (MatchNot (Match (Dst _))) = False" |
    "normalized_dst_ips (MatchNot (Match _)) = True" |
    "normalized_dst_ips (MatchAnd m1 m2) = (normalized_dst_ips m1  normalized_dst_ips m2)" |
    "normalized_dst_ips (MatchNot (MatchAnd _ _)) = False" |
    "normalized_dst_ips (MatchNot (MatchNot _)) = False" |
    "normalized_dst_ips (MatchNot MatchAny) = True" 
  
  lemma normalized_dst_ips_def2: "normalized_dst_ips ms = normalized_n_primitive (is_Dst, dst_sel) normalized_cidr_ip ms"
    by(induction ms rule: normalized_dst_ips.induct, simp_all add: normalized_cidr_ip_def)
  

  (*possible optimizations: remove the UNIV match on ip here!*)
  value "normalize_primitive_extract (is_Src, src_sel) Src ipt_iprange_compress
      (MatchAnd (MatchNot (Match ((Src_Ports (L4Ports TCP [(1,2)])):: 32 common_primitive))) (Match (Src_Ports (L4Ports TCP [(1,2)]))))"
  value "normalize_primitive_extract (is_Src, src_sel) Src ipt_iprange_compress
      (MatchAnd (MatchNot (Match (Src (IpAddrNetmask (10::ipv4addr) 2)))) (Match (Src_Ports (L4Ports TCP [(1,2)]))))"
  value "normalize_primitive_extract (is_Src, src_sel) Src ipt_iprange_compress
      (MatchAnd (Match (Src (IpAddrNetmask (10::ipv4addr) 2))) (MatchAnd (Match (Src (IpAddrNetmask 10 8))) (Match (Src_Ports (L4Ports TCP [(1,2)])))))"
  (*too many MatchAny*)
  value "normalize_primitive_extract (is_Src, src_sel) Src ipt_iprange_compress
      (MatchAnd (Match (Src (IpAddrNetmask (10::ipv4addr) 2))) (MatchAnd (Match (Src (IpAddrNetmask 192 8))) (Match (Src_Ports (L4Ports TCP [(1,2)])))))"


  definition normalize_src_ips :: "'i::len common_primitive match_expr  'i common_primitive match_expr list" where
    "normalize_src_ips = normalize_primitive_extract (common_primitive.is_Src, src_sel)
                                      common_primitive.Src ipt_iprange_compress"
  
  lemma ipt_iprange_compress_src_matching: "match_list (common_matcher, α) (map (Match  Src) (ipt_iprange_compress ml)) a p 
         matches (common_matcher, α) (alist_and (NegPos_map Src ml)) a p"
    proof -
      have "matches (common_matcher, α) (alist_and (NegPos_map common_primitive.Src ml)) a p 
            (m  set (getPos ml). matches (common_matcher, α) (Match (Src m)) a p) 
            (m  set (getNeg ml). matches (common_matcher, α) (MatchNot (Match (Src m))) a p)"
        by(induction ml rule: alist_and.induct) (auto simp add: bunch_of_lemmata_about_matches)
      also have "   p_src p   ( ip  set (getPos ml). ipt_iprange_to_set ip) - ( ip  set (getNeg ml). ipt_iprange_to_set ip)"
       by(simp add: match_simplematcher_SrcDst match_simplematcher_SrcDst_not)
      also have "  p_src p  ( ip  set (ipt_iprange_compress ml). ipt_iprange_to_set ip)" using ipt_iprange_compress
        by blast
      also have "  (ip  set (ipt_iprange_compress ml). matches (common_matcher, α) (Match (Src ip)) a p)"
       by(simp add: match_simplematcher_SrcDst)
      finally show ?thesis using match_list_matches by fastforce
  qed
  lemma normalize_src_ips: "normalized_nnf_match m  
      match_list (common_matcher, α) (normalize_src_ips m) a p = matches (common_matcher, α) m a p"
    unfolding normalize_src_ips_def
    using normalize_primitive_extract[OF _ wf_disc_sel_common_primitive(3), where f=ipt_iprange_compress and γ="(common_matcher, α)"]
      ipt_iprange_compress_src_matching by blast

  lemma normalize_src_ips_normalized_n_primitive: "normalized_nnf_match m  
      m'  set (normalize_src_ips m). normalized_src_ips m'"
  unfolding normalize_src_ips_def
  unfolding normalized_src_ips_def2
  apply(rule normalize_primitive_extract_normalizes_n_primitive[OF _ wf_disc_sel_common_primitive(3)])
   by(simp_all add: ipt_iprange_compress_normalized_IpAddrNetmask)


  definition normalize_dst_ips :: "'i::len common_primitive match_expr  'i common_primitive match_expr list" where
    "normalize_dst_ips = normalize_primitive_extract (common_primitive.is_Dst, dst_sel)
                                common_primitive.Dst ipt_iprange_compress"

  lemma ipt_iprange_compress_dst_matching: "match_list (common_matcher, α) (map (Match  Dst) (ipt_iprange_compress ml)) a p 
         matches (common_matcher, α) (alist_and (NegPos_map Dst ml)) a p"
    proof -
      have "matches (common_matcher, α) (alist_and (NegPos_map common_primitive.Dst ml)) a p 
            (m  set (getPos ml). matches (common_matcher, α) (Match (Dst m)) a p) 
            (m  set (getNeg ml). matches (common_matcher, α) (MatchNot (Match (Dst m))) a p)"
        by(induction ml rule: alist_and.induct) (auto simp add: bunch_of_lemmata_about_matches)
      also have "   p_dst p   ( ip  set (getPos ml). ipt_iprange_to_set ip) - ( ip  set (getNeg ml). ipt_iprange_to_set ip)"
       by(simp add: match_simplematcher_SrcDst match_simplematcher_SrcDst_not)
      also have "  p_dst p  ( ip  set (ipt_iprange_compress ml). ipt_iprange_to_set ip)" using ipt_iprange_compress by blast
      also have "  (ip  set (ipt_iprange_compress ml). matches (common_matcher, α) (Match (Dst ip)) a p)"
       by(simp add: match_simplematcher_SrcDst)
      finally show ?thesis using match_list_matches by fastforce
  qed
  lemma normalize_dst_ips: "normalized_nnf_match m  
      match_list (common_matcher, α) (normalize_dst_ips m) a p = matches (common_matcher, α) m a p"
    unfolding normalize_dst_ips_def
    using normalize_primitive_extract[OF _ wf_disc_sel_common_primitive(4), where f=ipt_iprange_compress and γ="(common_matcher, α)"]
      ipt_iprange_compress_dst_matching by blast

   text‹Normalizing the dst ips preserves the normalized src ips›
   lemma "normalized_nnf_match m  normalized_src_ips m  mnset (normalize_dst_ips m). normalized_src_ips mn"
   unfolding normalize_dst_ips_def normalized_src_ips_def2
   by(rule normalize_primitive_extract_preserves_unrelated_normalized_n_primitive)(simp_all add: wf_disc_sel_common_primitive)



  lemma normalize_dst_ips_normalized_n_primitive: "normalized_nnf_match m 
    m'  set (normalize_dst_ips m). normalized_dst_ips m'"
  unfolding normalize_dst_ips_def normalized_dst_ips_def2
  by(rule normalize_primitive_extract_normalizes_n_primitive[OF _ wf_disc_sel_common_primitive(4)]) (simp_all add: ipt_iprange_compress_normalized_IpAddrNetmask)

end

Theory Interfaces_Normalize

theory Interfaces_Normalize
imports Common_Primitive_Lemmas
begin



subsection‹Optimizing interfaces in match expressions›

  (*returns: (list of positive interfaces × a list of negated interfaces)
    it matches the conjunction of both
    None if the expression cannot match*)
  definition compress_interfaces :: "iface negation_type list  (iface list × iface list) option" where
    "compress_interfaces ifces  case (compress_pos_interfaces (getPos ifces))
        of None  None
        |  Some i  if
                       negated_ifce  set (getNeg ifces). iface_subset i negated_ifce
                     then
                       None
                     else if
                        ¬ iface_is_wildcard i
                      then
                        Some ([i], [])
                      else
                       Some ((if i = ifaceAny then [] else [i]), getNeg ifces)"


context
begin
  private lemma compress_interfaces_None:
    assumes generic: "primitive_matcher_generic β"
    shows   
      "compress_interfaces ifces = None  ¬ matches (β, α) (alist_and (NegPos_map IIface ifces)) a p"
      "compress_interfaces ifces = None  ¬ matches (β, α) (alist_and (NegPos_map OIface ifces)) a p"
      apply(simp_all add: compress_interfaces_def)
      apply(simp_all add: nt_match_list_matches[symmetric] nt_match_list_simp)
      apply(simp_all add: NegPos_map_simps primitive_matcher_generic.Iface_single[OF generic]
                          primitive_matcher_generic.Iface_single_not[OF generic])
      apply(case_tac [!] "compress_pos_interfaces (getPos ifces)")
        apply(simp_all)
        apply(drule_tac p_i="p_iiface p" in compress_pos_interfaces_None)
        apply(simp; fail)
       apply(drule_tac p_i="p_iiface p" in compress_pos_interfaces_Some)
       apply(simp split:if_split_asm)
       using iface_subset apply blast
       apply(drule_tac p_i="p_oiface p" in compress_pos_interfaces_None)
       apply(simp; fail)
      apply(drule_tac p_i="p_oiface p" in compress_pos_interfaces_Some)
      apply(simp split:if_split_asm)
      using iface_subset by blast
  
  private lemma compress_interfaces_Some: 
    assumes generic: "primitive_matcher_generic β"
    shows 
      "compress_interfaces ifces = Some (i_pos, i_neg) 
        matches (β, α) (alist_and (NegPos_map IIface ((map Pos i_pos)@(map Neg i_neg)))) a p 
        matches (β, α) (alist_and (NegPos_map IIface ifces)) a p"
      "compress_interfaces ifces = Some (i_pos, i_neg) 
        matches (β, α) (alist_and (NegPos_map OIface ((map Pos i_pos)@(map Neg i_neg)))) a p 
        matches (β, α) (alist_and (NegPos_map OIface ifces)) a p"
      apply(simp_all add: compress_interfaces_def)
      apply(simp_all add: bunch_of_lemmata_about_matches(1) alist_and_append NegPos_map_append)
      apply(simp_all add: nt_match_list_matches[symmetric] nt_match_list_simp)
      apply(simp_all add: NegPos_map_simps primitive_matcher_generic.Iface_single[OF generic]
                          primitive_matcher_generic.Iface_single_not[OF generic])
      apply(case_tac [!] "compress_pos_interfaces (getPos ifces)")
         apply(simp_all)
       apply(drule_tac p_i="p_iiface p" in compress_pos_interfaces_Some)
       apply(simp split:if_split_asm)
         using iface_is_wildcard_def iface_subset match_iface_case_nowildcard apply fastforce
        using match_ifaceAny apply blast
       apply force
      apply(drule_tac p_i="p_oiface p" in compress_pos_interfaces_Some)
      apply(simp split:if_split_asm)
        using iface_is_wildcard_def iface_subset match_iface_case_nowildcard apply fastforce
       using match_ifaceAny apply blast
      by force

  
  definition compress_normalize_input_interfaces :: "'i::len common_primitive match_expr  'i common_primitive match_expr option" where 
    "compress_normalize_input_interfaces m  compress_normalize_primitive (is_Iiface, iiface_sel) IIface compress_interfaces m"

  lemma compress_normalize_input_interfaces_Some:
  assumes generic: "primitive_matcher_generic β"
      and "normalized_nnf_match m" and "compress_normalize_input_interfaces m = Some m'"
    shows "matches (β, α) m' a p  matches (β, α) m a p"
    apply(rule compress_normalize_primitive_Some[OF assms(2) wf_disc_sel_common_primitive(5)])
     using assms(3) apply(simp add: compress_normalize_input_interfaces_def; fail)
    using compress_interfaces_Some[OF generic] by simp

  lemma compress_normalize_input_interfaces_None:
  assumes generic: "primitive_matcher_generic β"
      and "normalized_nnf_match m" and "compress_normalize_input_interfaces m = None"
    shows "¬ matches (β, α) m a p"
    apply(rule compress_normalize_primitive_None[OF assms(2) wf_disc_sel_common_primitive(5)])
     using assms(3) apply(simp add: compress_normalize_input_interfaces_def; fail)
    using compress_interfaces_None[OF generic] by simp

  lemma compress_normalize_input_interfaces_nnf: "normalized_nnf_match m  compress_normalize_input_interfaces m = Some m' 
      normalized_nnf_match m'"
    unfolding compress_normalize_input_interfaces_def
    using compress_normalize_primitive_nnf[OF wf_disc_sel_common_primitive(5)] by blast
 
  lemma compress_normalize_input_interfaces_not_introduces_Iiface:
    "¬ has_disc is_Iiface m  normalized_nnf_match m  compress_normalize_input_interfaces m = Some m' 
     ¬ has_disc is_Iiface m'"
      apply(simp add: compress_normalize_input_interfaces_def)
      apply(drule compress_normalize_primitive_not_introduces_C[where m=m and C'=IIface])
          apply(simp_all add: wf_disc_sel_common_primitive(5))
      by(simp add: compress_interfaces_def iface_is_wildcard_ifaceAny)
      
  lemma compress_normalize_input_interfaces_not_introduces_Iiface_negated:
    assumes notdisc: "¬ has_disc_negated is_Iiface False m"
        and nm: "normalized_nnf_match m"
        and some: "compress_normalize_input_interfaces m = Some m'"
     shows "¬ has_disc_negated is_Iiface False m'"
     apply(rule compress_normalize_primitive_not_introduces_C_negated[OF notdisc wf_disc_sel_common_primitive(5) nm])
     using some apply(simp add: compress_normalize_input_interfaces_def)
     by(simp add: compress_interfaces_def split: option.split_asm if_split_asm)

  (* only for arbitrary discs that do not match Iiface*)
  lemma compress_normalize_input_interfaces_hasdisc:
    "¬ has_disc disc m  (a. ¬ disc (IIface a))  normalized_nnf_match m  compress_normalize_input_interfaces m = Some m' 
     normalized_nnf_match m'  ¬ has_disc disc m'"
     unfolding compress_normalize_input_interfaces_def
     using compress_normalize_primitive_hasdisc[OF _ wf_disc_sel_common_primitive(5)] by blast

   (* only for arbitrary discs that do not match Iiface*)
  lemma compress_normalize_input_interfaces_hasdisc_negated:
    "¬ has_disc_negated disc neg m  (a. ¬ disc (IIface a))  normalized_nnf_match m  compress_normalize_input_interfaces m = Some m' 
     normalized_nnf_match m'  ¬ has_disc_negated disc neg m'"
     unfolding compress_normalize_input_interfaces_def
     using compress_normalize_primitive_hasdisc_negated[OF _ wf_disc_sel_common_primitive(5)] by blast

  lemma compress_normalize_input_interfaces_preserves_normalized_n_primitive:
    "normalized_n_primitive (disc, sel) P m  (a. ¬ disc (IIface a))  normalized_nnf_match m  compress_normalize_input_interfaces m = Some m' 
     normalized_nnf_match m'  normalized_n_primitive (disc, sel) P m'"
     unfolding compress_normalize_input_interfaces_def
   using compress_normalize_primitve_preserves_normalized_n_primitive[OF _ wf_disc_sel_common_primitive(5)] by blast
  



  value[code] "compress_normalize_input_interfaces 
    (MatchAnd (MatchAnd (MatchAnd (Match ((IIface (Iface ''eth+'')::32 common_primitive))) (MatchNot (Match (IIface (Iface ''eth4''))))) (Match (IIface (Iface ''eth1''))))
              (Match (Prot (Proto TCP))))"
    
  value[code] "compress_normalize_input_interfaces (MatchAny:: 32 common_primitive match_expr)"




  definition compress_normalize_output_interfaces :: "'i::len common_primitive match_expr  'i common_primitive match_expr option" where 
    "compress_normalize_output_interfaces m  compress_normalize_primitive (is_Oiface, oiface_sel) OIface compress_interfaces m"

  lemma compress_normalize_output_interfaces_Some:
  assumes generic: "primitive_matcher_generic β"
      and "normalized_nnf_match m" and "compress_normalize_output_interfaces m = Some m'"
    shows "matches (β, α) m' a p  matches (β, α) m a p"
    apply(rule compress_normalize_primitive_Some[OF assms(2) wf_disc_sel_common_primitive(6)])
     using assms(3) apply(simp add: compress_normalize_output_interfaces_def; fail)
    using compress_interfaces_Some[OF generic] by simp

  lemma compress_normalize_output_interfaces_None:
  assumes generic: "primitive_matcher_generic β"
      and "normalized_nnf_match m" and "compress_normalize_output_interfaces m = None"
    shows "¬ matches (β, α) m a p"
    apply(rule compress_normalize_primitive_None[OF assms(2) wf_disc_sel_common_primitive(6)])
     using assms(3) apply(simp add: compress_normalize_output_interfaces_def; fail)
    using compress_interfaces_None[OF generic] by simp

  lemma compress_normalize_output_interfaces_nnf: "normalized_nnf_match m  compress_normalize_output_interfaces m = Some m' 
      normalized_nnf_match m'"
    unfolding compress_normalize_output_interfaces_def
    using compress_normalize_primitive_nnf[OF wf_disc_sel_common_primitive(6)] by blast
 
  lemma compress_normalize_output_interfaces_not_introduces_Oiface:
    "¬ has_disc is_Oiface m  normalized_nnf_match m  compress_normalize_output_interfaces m = Some m' 
     ¬ has_disc is_Oiface m'"
      apply(simp add: compress_normalize_output_interfaces_def)
      apply(drule compress_normalize_primitive_not_introduces_C[where m=m  and C'=OIface])
          apply(simp_all add: wf_disc_sel_common_primitive(6))
      by(simp add: compress_interfaces_def iface_is_wildcard_ifaceAny)
      
  lemma compress_normalize_output_interfaces_not_introduces_Oiface_negated:
    assumes notdisc: "¬ has_disc_negated is_Oiface False m"
        and nm: "normalized_nnf_match m"
        and some: "compress_normalize_output_interfaces m = Some m'"
     shows "¬ has_disc_negated is_Oiface False m'"
     apply(rule compress_normalize_primitive_not_introduces_C_negated[OF notdisc wf_disc_sel_common_primitive(6) nm])
     using some apply(simp add: compress_normalize_output_interfaces_def)
     by(simp add: compress_interfaces_def split: option.split_asm if_split_asm)

  (* only for arbitrary discs that do not match Oiface*)
  lemma compress_normalize_output_interfaces_hasdisc:
    "¬ has_disc disc m  (a. ¬ disc (OIface a))  normalized_nnf_match m  compress_normalize_output_interfaces m = Some m' 
     normalized_nnf_match m'  ¬ has_disc disc m'"
     unfolding compress_normalize_output_interfaces_def
     using compress_normalize_primitive_hasdisc[OF _ wf_disc_sel_common_primitive(6)] by blast

   (* only for arbitrary discs that do not match Oiface*)
  lemma compress_normalize_output_interfaces_hasdisc_negated:
    "¬ has_disc_negated disc neg m  (a. ¬ disc (OIface a))  normalized_nnf_match m  compress_normalize_output_interfaces m = Some m' 
     normalized_nnf_match m'  ¬ has_disc_negated disc neg m'"
     unfolding compress_normalize_output_interfaces_def
     using compress_normalize_primitive_hasdisc_negated[OF _ wf_disc_sel_common_primitive(6)] by blast

  lemma compress_normalize_output_interfaces_preserves_normalized_n_primitive:
    "normalized_n_primitive (disc, sel) P m  (a. ¬ disc (OIface a))  normalized_nnf_match m  compress_normalize_output_interfaces m = Some m' 
     normalized_nnf_match m'  normalized_n_primitive (disc, sel) P m'"
     unfolding compress_normalize_output_interfaces_def
   using compress_normalize_primitve_preserves_normalized_n_primitive[OF _ wf_disc_sel_common_primitive(6)] by blast

end

end

Theory Word_Upto

section‹Word Upto›
theory Word_Upto
imports Main
  IP_Addresses.Hs_Compat
  Word_Lib.Word_Lemmas
begin


text‹Enumerate a range of machine words.›

text‹enumerate from the back (inefficient)›
function word_upto :: "'a word  'a word  ('a::len) word list" where
"word_upto a b = (if a = b then [a] else word_upto a (b - 1) @ [b])"
by pat_completeness auto

(*by the way: does not terminate practically if b < a; will terminate after it
  reaches the word wrap-around!*)

termination word_upto
apply(relation "measure (unat  uncurry (-)  prod.swap)")
 apply(rule wf_measure; fail)
apply(simp)
apply(subgoal_tac "unat (b - a - 1) < unat (b - a)")
 apply(simp add: diff_right_commute; fail)
apply(rule measure_unat)
apply auto
done

declare word_upto.simps[simp del]
 

text‹enumerate from the front (more inefficient)›
function word_upto' :: "'a word  'a word  ('a::len) word list" where
"word_upto' a b = (if a = b then [a] else a # word_upto' (a + 1) b)"
by pat_completeness auto

termination word_upto'
apply(relation "measure (λ (a, b). unat (b - a))")
 apply(rule wf_measure; fail)
apply(simp)
apply(subgoal_tac "unat (b - a - 1) < unat (b - a)")
 apply (simp add: diff_diff_add; fail)
apply(rule measure_unat)
apply auto
done

declare word_upto'.simps[simp del]

lemma word_upto_cons_front[code]:
 "word_upto a b = word_upto' a b"
 proof(induction a b rule:word_upto'.induct)
 case (1 a b)
   have hlp1: "a  b  a # word_upto (a + 1) b = word_upto a b"
   apply(induction a b rule:word_upto.induct)
   apply simp
   apply(subst(1) word_upto.simps)
   apply(simp)
   apply safe
    apply(subst(1) word_upto.simps)
    apply (simp)
    apply(subst(1) word_upto.simps)
    apply (simp; fail)
   apply(case_tac "a  b - 1")
    apply(simp)
    apply (metis Cons_eq_appendI word_upto.simps)
   apply(simp)
   done

   from 1[symmetric] show ?case
     apply(cases "a = b")
      subgoal
      apply(subst word_upto.simps)
      apply(subst word_upto'.simps)
      by(simp)
     apply(subst word_upto'.simps)
     by(simp add: hlp1)
 qed


(* Most of the lemmas I show about word_upto hold without a ≤ b,
   but I don't need that right now and it's giving me a headache *)


lemma word_upto_set_eq: "a  b  x  set (word_upto a b)  a  x  x  b"
proof
  show "a  b  x  set (word_upto a b)  a  x  x  b"
    apply(induction a b rule: word_upto.induct)
    apply(case_tac "a = b")
     apply(subst(asm) word_upto.simps)
     apply(simp; fail)
    apply(subst(asm) word_upto.simps)
    apply(simp)
    apply(erule disjE)
     apply(simp; fail)
    proof(goal_cases)
     case (1 a b)
     from 1(2-3) have "b  0" by force
     from 1(2,3) have "a  b - 1"
       by (simp add: word_le_minus_one_leq)
     from 1(1)[OF this 1(4)] show ?case by (metis dual_order.trans 1(2,3) less_imp_le measure_unat word_le_0_iff word_le_nat_alt)
    qed
next
  show "a  x  x  b  x  set (word_upto a b)"
    apply(induction a b rule: word_upto.induct)
    apply(case_tac "a = b")
     apply(subst word_upto.simps)
     apply(simp; force)
    apply(subst word_upto.simps)
    apply(simp)
    apply(case_tac "x = b")
     apply(simp;fail)
    proof(goal_cases)
       case (1 a b)
       from 1(2-4) have "b  0" by force
       from 1(2,4) have "x  b - 1"
         using le_step_down_word by auto
       from 1(1) this show ?case by simp
    qed
qed

lemma word_upto_distinct_hlp: "a  b  a  b  b  set (word_upto a (b - 1))"
   apply(rule ccontr, unfold not_not)
   apply(subgoal_tac "a  b - 1")
    apply(drule iffD1[OF word_upto_set_eq[of a "b -1" b]])
     apply(simp add: word_upto.simps)
    apply(subgoal_tac "b  0")
     apply(meson leD measure_unat word_le_nat_alt)
   apply(blast intro: iffD1[OF word_le_0_iff])
  using le_step_down_word apply blast
done

lemma distinct_word_upto: "a  b  distinct (word_upto a b)"
apply(induction a b rule: word_upto.induct)
apply(case_tac "a = b")
 apply(subst word_upto.simps)
 apply(simp; force)
apply(subst word_upto.simps)
apply(case_tac "a  b - 1")
 apply(simp)
 apply(rule word_upto_distinct_hlp; simp)
apply(simp)
  apply(rule ccontr)
  apply (simp add: not_le antisym word_minus_one_le_leq)
done


lemma word_upto_eq_upto: "s  e  e  unat (max_word :: 'l word) 
       word_upto ((of_nat :: nat  ('l :: len) word) s) (of_nat e) = map of_nat (upt s (Suc e))"
proof(induction e)
  let ?mwon = "of_nat :: nat  'l word"
  let ?mmw = "max_word :: 'l word"
  case (Suc e)
  show ?case
  proof(cases "?mwon s = ?mwon (Suc e)")
    case True
    have "s = Suc e" using le_unat_uoi Suc.prems True by metis
    with True show ?thesis by(subst word_upto.simps) (simp)
  next
    case False
    hence le: "s  e" using le_SucE Suc.prems by blast
    have lm: "e  unat ?mmw" using Suc.prems by simp
    have sucm: "(of_nat :: nat  ('l :: len) word) (Suc e) - 1 = of_nat e" using Suc.prems(2) by simp
    note mIH = Suc.IH[OF le lm]
    show ?thesis by(subst word_upto.simps) (simp add: False[simplified] Suc.prems mIH sucm)
  qed
qed(simp add: word_upto.simps)

lemma word_upto_alt: "(a :: ('l :: len) word)  b 
  word_upto a b = map of_nat (upt (unat a) (Suc (unat b)))"
proof -
   let ?mmw = "max_word :: 'l word"
   assume le: "a  b"
   hence nle: "unat a  unat b" by(unat_arith)
   have lem: "unat b  unat ?mmw" by (simp add: word_unat_less_le) 
   note word_upto_eq_upto[OF nle lem, unfolded word_unat.Rep_inverse]
   thus "word_upto a b = map of_nat [unat a..<Suc (unat b)]" .
qed

lemma word_upto_upt:
  "word_upto a b = (if a  b then map of_nat (upt (unat a) (Suc (unat b))) else word_upto a b)"
  using word_upto_alt by metis

lemma sorted_word_upto:
  fixes a b :: "('l :: len) word"
  assumes "a  b"
  shows "sorted (word_upto a b)"
proof -
  define m and n where m = unat a and n = Suc (unat b)
  moreover have ‹sorted (map of_nat [m..<n] :: 'l word list)
    apply (simp add: sorted_map)
    apply (rule sorted_wrt_mono_rel [of _ (≤)])
     apply (simp_all flip: sorted_sorted_wrt)
    apply (simp add: le_unat_uoi less_Suc_eq_le n_def word_of_nat_le)
    apply transfer
    apply simp
    apply (subst take_bit_int_eq_self)
      apply (simp_all add: le_less_trans)
    apply (metis le_unat_uoi of_int_of_nat_eq of_nat_mono uint_word_of_int_eq unat_eq_nat_uint unsigned_of_int)
    done
  ultimately have ‹sorted (map of_nat [unat a..<Suc (unat b)] :: 'l word list)
    by simp
  with assms show ?thesis
    by (simp only: word_upto_alt)
qed

end

Theory Protocols_Normalize

theory Protocols_Normalize
imports Common_Primitive_Lemmas
  "../Common/Word_Upto"
begin

section‹Optimizing Protocols›

section‹Optimizing protocols in match expressions›

  fun compress_pos_protocols :: "protocol list  protocol option" where
    "compress_pos_protocols [] = Some ProtoAny" |
    "compress_pos_protocols [p] = Some p" |
    "compress_pos_protocols (p1#p2#ps) = (case simple_proto_conjunct p1 p2 of None  None | Some p  compress_pos_protocols (p#ps))"

  lemma compress_pos_protocols_Some: "compress_pos_protocols ps = Some proto  
          match_proto proto p_prot  ( p  set ps. match_proto p p_prot)"
    proof(induction ps rule: compress_pos_protocols.induct)
    case (3 p1 p2 pps) thus ?case
      apply(cases "simple_proto_conjunct p1 p2")
       apply(simp; fail)
      using simple_proto_conjunct_Some by(simp)
    qed(simp)+

  lemma compress_pos_protocols_None: "compress_pos_protocols ps = None  
          ¬ ( proto  set ps. match_proto proto p_prot)"
    proof(induction ps rule: compress_pos_protocols.induct)
    case (3 i1 i2 iis) thus ?case
      apply(cases "simple_proto_conjunct i1 i2")
       apply(simp_all)
       using simple_proto_conjunct_None apply blast
      using simple_proto_conjunct_Some by blast
    qed(simp)+

(*the intuition behind the compress_protocols*)
lemma "simple_proto_conjunct (Proto p1) (Proto p2)  None  pkt. match_proto (Proto p1) pkt  match_proto (Proto p2) pkt"
  apply(subgoal_tac "p1 = p2")
   apply(simp)
  apply(simp split: if_split_asm)
  done
lemma "simple_proto_conjunct p1 (Proto p2)  None  pkt. match_proto (Proto p2) pkt  match_proto p1 pkt"
 apply(cases p1)
  apply(simp)
 apply(simp split: if_split_asm)
 done

  definition compress_protocols :: "protocol negation_type list  (protocol list × protocol list) option" where
    "compress_protocols ps  case (compress_pos_protocols (getPos ps))
        of None  None
        |  Some proto  if ProtoAny  set (getNeg ps)  (p  {0..max_word}. Proto p  set (getNeg ps)) then
                           None
                         else if proto = ProtoAny then
                           Some ([], getNeg ps)
                         else if (p  set (getNeg ps). simple_proto_conjunct proto p  None) then
                           None
                         else
                          ― ‹proto› is a primitive_protocol› here. This is strict equality match, e.g.›
                          ― ‹protocol must be TCP. Thus, we can remove all negative matches!›
                           Some ([proto], [])"
  
  (* It is kind of messy to find a definition that checks whether a match is the exhaustive list
    and is executable *)
  lemma all_proto_hlp2: "ProtoAny  a  (p  {0..max_word}. Proto p  a) 
                               ProtoAny  a  a = {p. p  ProtoAny}"
  proof -   
    have all_proto_hlp: "ProtoAny  a  (p  {0..max_word}. Proto p  a)  a = {p. p  ProtoAny}"
      by(auto intro: protocol.exhaust)
    thus ?thesis by blast
  qed

  lemma set_word8_word_upto: "{0..(max_word :: 8 word)} = set (word_upto 0 255)"
  proof -
    have 0xFF = (max_word :: 8 word)
      by simp
    then show ?thesis
      by (simp only:) (auto simp add: word_upto_set_eq)
  qed
  lemma "(p  {0..max_word}. Proto p  set (getNeg ps)) 
         ((p  set (word_upto 0 255). Proto p  set (getNeg ps)))"
    by(simp add: set_word8_word_upto)
 
  
  lemma compress_protocols_code[code]:
    "compress_protocols ps = (case (compress_pos_protocols (getPos ps))
        of None  None
        |  Some proto  if ProtoAny  set (getNeg ps)  (p  set (word_upto 0 255). Proto p  set (getNeg ps)) then
                           None
                         else if proto = ProtoAny then
                           Some ([], getNeg ps)
                         else if (p  set (getNeg ps). simple_proto_conjunct proto p  None) then
                           None
                         else
                           Some ([proto], [])
        )"
    unfolding compress_protocols_def
    using set_word8_word_upto by presburger

  (*fully optimized, i.e. we cannot compress it better*)
  lemma "compress_protocols ps = Some (ps_pos, ps_neg) 
     p. ((mset ps_pos. match_proto m p)  (mset ps_neg. ¬ match_proto m p))"
    apply(simp add: compress_protocols_def all_proto_hlp2 split: option.split_asm if_split_asm)
     apply(subgoal_tac "p. (Proto p)  set ps_neg")
      apply(elim exE)
      apply(rename_tac x2 p)
      apply(rule_tac x=p in exI)
      apply(blast elim: match_proto.elims)
     apply(auto intro: protocol.exhaust)
    done
  
  definition compress_normalize_protocols_step :: "'i::len common_primitive match_expr  'i common_primitive match_expr option" where 
    "compress_normalize_protocols_step m  compress_normalize_primitive (is_Prot, prot_sel) Prot compress_protocols m"

  lemma (in primitive_matcher_generic) compress_normalize_protocols_step_Some:
  assumes "normalized_nnf_match m" and "compress_normalize_protocols_step m = Some m'"
    shows "matches (β, α) m' a p  matches (β, α) m a p"
  proof(rule compress_normalize_primitive_Some[OF assms(1) wf_disc_sel_common_primitive(7), of compress_protocols])
    show "compress_normalize_primitive (is_Prot, prot_sel) Prot compress_protocols m = Some m'"
      using assms(2) by(simp add: compress_normalize_protocols_step_def)
  next
    fix ps ps_pos ps_neg
    show "compress_protocols ps = Some (ps_pos, ps_neg) 
      matches (β, α) (alist_and (NegPos_map Prot ((map Pos ps_pos)@(map Neg ps_neg)))) a p 
      matches (β, α) (alist_and (NegPos_map Prot ps)) a p"
      apply(simp add: compress_protocols_def)
      apply(simp add: bunch_of_lemmata_about_matches alist_and_append NegPos_map_append)
      apply(simp add: nt_match_list_matches[symmetric] nt_match_list_simp)
      apply(simp add: NegPos_map_simps Prot_single Prot_single_not)
      apply(case_tac "compress_pos_protocols (getPos ps)")
       apply(simp_all)
      apply(drule_tac p_prot="p_proto p" in compress_pos_protocols_Some)
      apply(simp split:if_split_asm)
      using simple_proto_conjunct_None by auto
  qed

  lemma (in primitive_matcher_generic) compress_normalize_protocols_step_None:
  assumes "normalized_nnf_match m" and "compress_normalize_protocols_step m = None"
    shows "¬ matches (β, α) m a p"
  proof(rule compress_normalize_primitive_None[OF assms(1) wf_disc_sel_common_primitive(7), of "compress_protocols"])
    show "compress_normalize_primitive (is_Prot, prot_sel) Prot compress_protocols m = None"  
      using assms(2) by(simp add: compress_normalize_protocols_step_def)
    next
      fix ps
      have if_option_Some:
        "((if P then None else Some x) = Some y) = (¬P  x = y)"
        for P and x::protocol and y by simp
      show "compress_protocols ps = None  ¬ matches (β, α) (alist_and (NegPos_map Prot ps)) a p"
        apply(simp add: compress_protocols_def)
        apply(simp add: nt_match_list_matches[symmetric] nt_match_list_simp)
        apply(simp add: NegPos_map_simps Prot_single Prot_single_not)
        apply(cases "compress_pos_protocols (getPos ps)")
         apply(simp_all)
         apply(drule_tac p_prot="p_proto p" in compress_pos_protocols_None)
         apply(simp; fail)
        apply(drule_tac p_prot="p_proto p" in compress_pos_protocols_Some)
        apply(simp split:if_split_asm)
         apply fastforce
        apply(elim bexE exE)
        apply(simp)
        apply(elim simple_proto_conjunct.elims)
          apply(simp; fail)
         apply(simp; fail)
        using if_option_Some by metis
    qed

  lemma compress_normalize_protocols_step_nnf:
    "normalized_nnf_match m  compress_normalize_protocols_step m = Some m' 
      normalized_nnf_match m'"
    unfolding compress_normalize_protocols_step_def
    using compress_normalize_primitive_nnf[OF wf_disc_sel_common_primitive(7)] by blast
 
  (*not needed, I want it to introduce prot when I import from L4Ports!*)
  lemma compress_normalize_protocols_step_not_introduces_Prot:
    "¬ has_disc is_Prot m  normalized_nnf_match m  compress_normalize_protocols_step m = Some m' 
     ¬ has_disc is_Prot m'"
      apply(simp add: compress_normalize_protocols_step_def)
      apply(drule compress_normalize_primitive_not_introduces_C[where m=m and C'=Prot])
          apply(simp_all add: wf_disc_sel_common_primitive(7))
      apply(simp add: compress_protocols_def split: if_splits)
      done

  lemma compress_normalize_protocols_step_not_introduces_Prot_negated:
    assumes notdisc: "¬ has_disc_negated is_Prot False m"
        and nm: "normalized_nnf_match m"
        and some: "compress_normalize_protocols_step m = Some m'"
     shows "¬ has_disc_negated is_Prot False m'"
     apply(rule compress_normalize_primitive_not_introduces_C_negated[OF notdisc wf_disc_sel_common_primitive(7) nm])
     using some apply(simp add: compress_normalize_protocols_step_def)
     by(simp add: compress_protocols_def split: option.split_asm if_split_asm)


  lemma compress_normalize_protocols_step_hasdisc:
    "¬ has_disc disc m  (a. ¬ disc (Prot a))  normalized_nnf_match m  compress_normalize_protocols_step m = Some m' 
     normalized_nnf_match m'  ¬ has_disc disc m'"
     unfolding compress_normalize_protocols_step_def
     using compress_normalize_primitive_hasdisc[OF _ wf_disc_sel_common_primitive(7)] by blast

  lemma compress_normalize_protocols_step_hasdisc_negated:
    "¬ has_disc_negated disc neg m  (a. ¬ disc (Prot a))  normalized_nnf_match m  compress_normalize_protocols_step m = Some m' 
     normalized_nnf_match m'  ¬ has_disc_negated disc neg m'"
     unfolding compress_normalize_protocols_step_def
     using compress_normalize_primitive_hasdisc_negated[OF _ wf_disc_sel_common_primitive(7)] by blast


  lemma compress_normalize_protocols_step_preserves_normalized_n_primitive:
    "normalized_n_primitive (disc, sel) P m  (a. ¬ disc (Prot a))  normalized_nnf_match m  compress_normalize_protocols_step m = Some m' 
     normalized_nnf_match m'  normalized_n_primitive (disc, sel) P m'"
     unfolding compress_normalize_protocols_step_def
   using compress_normalize_primitve_preserves_normalized_n_primitive[OF _ wf_disc_sel_common_primitive(7)] by blast
  

  lemma "case compress_normalize_protocols_step 
    (MatchAnd (MatchAnd (MatchAnd (Match ((Prot (Proto TCP)):: 32 common_primitive)) (MatchNot (Match (Prot (Proto UDP))))) (Match (IIface (Iface ''eth1''))))
              (Match (Prot (Proto TCP)))) of Some ps  opt_MatchAny_match_expr ps
  = MatchAnd (Match (Prot (Proto 6))) (Match (IIface (Iface ''eth1'')))" by eval
    
  value[code] "compress_normalize_protocols_step (MatchAny:: 32 common_primitive match_expr)"


subsection‹Importing the matches on @{typ primitive_protocol} from @{const L4Ports}

  (* add protocols from positive L4 ports into optimization. *)
  definition import_protocols_from_ports
    :: "'i::len common_primitive match_expr  'i common_primitive match_expr" where 
  "import_protocols_from_ports m 
    (case primitive_extractor (is_Src_Ports, src_ports_sel) m of (srcpts, rst1) 
     case primitive_extractor (is_Dst_Ports, dst_ports_sel) rst1 of (dstpts, rst2) 
      MatchAnd
      (MatchAnd
       (MatchAnd
        (andfold_MatchExp (map (Match  (Prot  (case_ipt_l4_ports (λproto x. Proto proto)))) (getPos srcpts)))
        (andfold_MatchExp (map (Match  (Prot  (case_ipt_l4_ports (λproto x. Proto proto)))) (getPos dstpts)))
       )
        (alist_and' (NegPos_map Src_Ports srcpts @ NegPos_map Dst_Ports dstpts))
       )
         rst2
     )"

  text‹The @{const Proto} and @{const L4Ports} match make the following match impossible:›
  lemma "compress_normalize_protocols_step (import_protocols_from_ports 
    (MatchAnd (MatchAnd (Match (Prot (Proto TCP):: 32 common_primitive))
      (Match (Src_Ports (L4Ports UDP [(22,22)])))) (Match (IIface (Iface ''eth1''))))) = None"
  by eval


  (*unfolding the whole primitive_extractor*)
  lemma import_protocols_from_ports_erule: "normalized_nnf_match m  P m 
    (srcpts rst1 dstpts rst2.
       normalized_nnf_match m 
       ― ‹P m ⟹› erule consumes only first argument›
       primitive_extractor (is_Src_Ports, src_ports_sel) m = (srcpts, rst1) 
       primitive_extractor (is_Dst_Ports, dst_ports_sel) rst1 = (dstpts, rst2) 
       normalized_nnf_match rst1 
       normalized_nnf_match rst2 
       P (MatchAnd
           (MatchAnd
             (MatchAnd
               (andfold_MatchExp
                 (map (Match  (Prot  (case_ipt_l4_ports (λproto x. Proto proto)))) (getPos srcpts)))
               (andfold_MatchExp
                 (map (Match  (Prot  (case_ipt_l4_ports (λproto x. Proto proto)))) (getPos dstpts))))
             (alist_and' (NegPos_map Src_Ports srcpts @ NegPos_map Dst_Ports dstpts)))
           rst2)) 
    P (import_protocols_from_ports m)"
    apply(simp add: import_protocols_from_ports_def)
    apply(case_tac "primitive_extractor (is_Src_Ports, src_ports_sel) m", rename_tac srcpts rst1)
    apply(simp)
    apply(case_tac "primitive_extractor (is_Dst_Ports, dst_ports_sel) rst1", rename_tac dstpts rst2)
    apply(simp)
    apply(frule(1) primitive_extractor_correct(2)[OF _ wf_disc_sel_common_primitive(1)])
    apply(frule(1) primitive_extractor_correct(2)[OF _ wf_disc_sel_common_primitive(2)])
    apply simp
    done

  lemma (in primitive_matcher_generic) import_protocols_from_ports:
  assumes normalized: "normalized_nnf_match m"
  shows "matches (β, α) (import_protocols_from_ports m) a p  matches (β, α) m a p"
  proof-
    have add_protocol:
    "matches (β, α)
      (andfold_MatchExp (map (Match  (Prot  (case_ipt_l4_ports (λproto x. Proto proto)))) (getPos as))) a p 
     matches (β, α) (alist_and (NegPos_map C as)) a p
     
     matches (β, α) (alist_and (NegPos_map C as)) a p"
    if C: "C = Src_Ports  C = Dst_Ports" for C as
      proof(induction as)
      case Nil thus ?case by(simp)
      next
      case (Cons x xs)
        show ?case
        proof(cases x)
        case Neg with Cons.IH show ?thesis
          apply(simp add: bunch_of_lemmata_about_matches)
          by blast
        next
        case (Pos portmatch)
          with Cons.IH show ?thesis
            apply(cases portmatch)
            apply(simp add: andfold_MatchExp_matches bunch_of_lemmata_about_matches)
            using Ports_single_rewrite_Prot C by blast
        qed
      qed
  from normalized show ?thesis
    apply -
    apply(erule import_protocols_from_ports_erule)
     apply(simp; fail)
    apply(subst primitive_extractor_correct(1)[OF normalized wf_disc_sel_common_primitive(1),
          where γ="(β,α)" and a=a and p=p, symmetric])
     apply(simp; fail)
    apply(drule(1) primitive_extractor_correct(1)[OF _ wf_disc_sel_common_primitive(2),
          where γ="(β,α)" and a=a and p=p])
    apply(simp add: bunch_of_lemmata_about_matches matches_alist_and_alist_and' alist_and_append)
    using add_protocol by blast
  qed


  lemma import_protocols_from_ports_nnf:
    "normalized_nnf_match m  normalized_nnf_match (import_protocols_from_ports m)"
    proof -
      have hlp: "mset (map (Match  (Prot  (case_ipt_l4_ports (λproto x. Proto proto)))) ls).
          normalized_nnf_match m" for ls
      apply(induction ls)
       apply(simp)
      apply(rename_tac l ls, case_tac l)
      by(simp)
    show "normalized_nnf_match m  normalized_nnf_match (import_protocols_from_ports m)"
      apply(rule import_protocols_from_ports_erule)
        apply(simp_all)
      apply(simp add: normalized_nnf_match_alist_and')
      apply(safe)
       apply(rule andfold_MatchExp_normalized_nnf, simp add: hlp)+
      done
    qed

  lemma import_protocols_from_ports_not_introduces_Prot_negated:
    "normalized_nnf_match m  ¬ has_disc_negated is_Prot False m 
      ¬ has_disc_negated is_Prot False (import_protocols_from_ports m)"
     apply(erule(1) import_protocols_from_ports_erule)
     apply(simp)
     apply(intro conjI)
        using andfold_MatchExp_not_disc_negated_mapMatch[
          where C="Prot  case_ipt_l4_ports (λproto x. Proto proto)", simplified] apply blast
       using andfold_MatchExp_not_disc_negated_mapMatch[
         where C="Prot  case_ipt_l4_ports (λproto x. Proto proto)", simplified] apply blast
      apply(simp add: has_disc_negated_alist_and')
      using not_has_disc_negated_NegPos_map[where disc=is_Prot and C=Src_Ports, simplified]
            not_has_disc_negated_NegPos_map[where disc=is_Prot and C=Dst_Ports, simplified] apply blast
     apply(drule(1) primitive_extractor_correct(6)[OF _ wf_disc_sel_common_primitive(1), where neg=False])
     apply(drule(1) primitive_extractor_correct(6)[OF _ wf_disc_sel_common_primitive(2), where neg=False])
     by blast


  lemma import_protocols_from_ports_hasdisc:
    "normalized_nnf_match m  ¬ has_disc disc m  (a. ¬ disc (Prot a)) 
     normalized_nnf_match (import_protocols_from_ports m)  ¬ has_disc disc (import_protocols_from_ports m)"
     apply(intro conjI)
      using import_protocols_from_ports_nnf apply blast
     apply(erule(1) import_protocols_from_ports_erule)
     apply(simp)
     apply(intro conjI)
        using andfold_MatchExp_not_disc_mapMatch[
          where C="Prot  case_ipt_l4_ports (λproto x. Proto proto)", simplified] apply blast
       using andfold_MatchExp_not_disc_mapMatch[
         where C="Prot  case_ipt_l4_ports (λproto x. Proto proto)", simplified] apply blast
      subgoal for srcpts rst1 dstpts rst2
      apply(frule(2) primitive_extractor_reassemble_not_has_disc[OF wf_disc_sel_common_primitive(1)])
      apply(subgoal_tac "¬ has_disc disc rst1")
       prefer 2
       apply(drule(1) primitive_extractor_correct(4)[OF _ wf_disc_sel_common_primitive(1)])
       apply blast
      apply(drule(2) primitive_extractor_reassemble_not_has_disc[OF wf_disc_sel_common_primitive(2)])
      using has_disc_alist_and'_append by blast
     apply(drule(1) primitive_extractor_correct(4)[OF _ wf_disc_sel_common_primitive(1)])
     apply(drule(1) primitive_extractor_correct(4)[OF _ wf_disc_sel_common_primitive(2)])
     apply blast
     done



  lemma import_protocols_from_ports_hasdisc_negated:
    "¬ has_disc_negated disc False m  (a. ¬ disc (Prot a))  normalized_nnf_match m 
     normalized_nnf_match (import_protocols_from_ports m) 
     ¬ has_disc_negated disc False (import_protocols_from_ports m)"
     apply(intro conjI)
      using import_protocols_from_ports_nnf apply blast
     apply(erule(1) import_protocols_from_ports_erule)
     apply(simp)
     apply(intro conjI)
        using andfold_MatchExp_not_disc_negated_mapMatch[
          where C="Prot  case_ipt_l4_ports (λproto x. Proto proto)", simplified] apply blast
       using andfold_MatchExp_not_disc_negated_mapMatch[
         where C="Prot  case_ipt_l4_ports (λproto x. Proto proto)", simplified] apply blast
      subgoal for srcpts rst1 dstpts rst2
      apply(frule(2) primitive_extractor_reassemble_not_has_disc_negated[OF wf_disc_sel_common_primitive(1)])
      apply(subgoal_tac "¬ has_disc_negated disc False rst1")
       prefer 2
       apply(drule(1) primitive_extractor_correct(6)[OF _ wf_disc_sel_common_primitive(1)])
       apply blast
      apply(drule(2) primitive_extractor_reassemble_not_has_disc_negated[OF wf_disc_sel_common_primitive(2)])
      using has_disc_negated_alist_and'_append by blast
     apply(drule(1) primitive_extractor_correct(6)[OF _ wf_disc_sel_common_primitive(1)])
     apply(drule(1) primitive_extractor_correct(6)[OF _ wf_disc_sel_common_primitive(2)])
     apply blast
     done


  lemma import_protocols_from_ports_preserves_normalized_n_primitive:
    "normalized_n_primitive (disc, sel) f m  (a. ¬ disc (Prot a))  normalized_nnf_match m 
     normalized_nnf_match (import_protocols_from_ports m)  normalized_n_primitive (disc, sel) f (import_protocols_from_ports m)"
     apply(intro conjI)
      using import_protocols_from_ports_nnf apply blast
     apply(erule(1) import_protocols_from_ports_erule)
     apply(simp)
     apply(intro conjI)
        subgoal for srcpts rst1 dstpts rst2
        apply(rule andfold_MatchExp_normalized_n_primitive)
        using normalized_n_primitive_impossible_map by blast
       subgoal for srcpts rst1 dstpts rst2
       apply(rule andfold_MatchExp_normalized_n_primitive)
       using normalized_n_primitive_impossible_map by blast
      subgoal for srcpts rst1 dstpts rst2
      apply(frule(2) primitive_extractor_reassemble_normalized_n_primitive[OF wf_disc_sel_common_primitive(1)])
      apply(subgoal_tac "normalized_n_primitive (disc, sel) f rst1")
       prefer 2
       apply(drule(1) primitive_extractor_correct(5)[OF _ wf_disc_sel_common_primitive(1)])
       apply blast
      apply(drule(2) primitive_extractor_reassemble_normalized_n_primitive[OF wf_disc_sel_common_primitive(2)])
      using normalized_n_primitive_alist_and'_append by blast
     apply(drule(1) primitive_extractor_correct(5)[OF _ wf_disc_sel_common_primitive(1)])
     apply(drule(1) primitive_extractor_correct(5)[OF _ wf_disc_sel_common_primitive(2)])
     apply blast
     done



subsection‹Putting things together›

 
  definition compress_normalize_protocols
    :: "'i::len common_primitive match_expr  'i common_primitive match_expr option" where 
    "compress_normalize_protocols m  compress_normalize_protocols_step (import_protocols_from_ports m)"

  lemma (in primitive_matcher_generic) compress_normalize_protocols_Some:
  assumes "normalized_nnf_match m" and "compress_normalize_protocols m = Some m'"
    shows "matches (β, α) m' a p  matches (β, α) m a p"
  using assms apply(simp add: compress_normalize_protocols_def)
  by (metis import_protocols_from_ports import_protocols_from_ports_nnf
            compress_normalize_protocols_step_Some)
   
  lemma (in primitive_matcher_generic) compress_normalize_protocols_None:
  assumes "normalized_nnf_match m" and "compress_normalize_protocols m = None"
    shows "¬ matches (β, α) m a p"
  using assms apply(simp add: compress_normalize_protocols_def)
  by (metis import_protocols_from_ports import_protocols_from_ports_nnf
            compress_normalize_protocols_step_None)
   

  lemma compress_normalize_protocols_nnf:
    "normalized_nnf_match m  compress_normalize_protocols m = Some m' 
      normalized_nnf_match m'"
  apply(simp add: compress_normalize_protocols_def)
  by (metis import_protocols_from_ports_nnf compress_normalize_protocols_step_nnf)
 

  lemma compress_normalize_protocols_not_introduces_Prot_negated:
    assumes notdisc: "¬ has_disc_negated is_Prot False m"
        and nm: "normalized_nnf_match m"
        and some: "compress_normalize_protocols m = Some m'"
     shows "¬ has_disc_negated is_Prot False m'"
    using assms apply(simp add: compress_normalize_protocols_def)
    using import_protocols_from_ports_nnf
          import_protocols_from_ports_not_introduces_Prot_negated
          compress_normalize_protocols_step_not_introduces_Prot_negated by auto


  lemma compress_normalize_protocols_hasdisc:
    "¬ has_disc disc m  (a. ¬ disc (Prot a))  normalized_nnf_match m  compress_normalize_protocols m = Some m' 
     normalized_nnf_match m'  ¬ has_disc disc m'"
    apply(simp add: compress_normalize_protocols_def)
    using import_protocols_from_ports_hasdisc
          compress_normalize_protocols_step_hasdisc by blast

  lemma compress_normalize_protocols_hasdisc_negated:
    "¬ has_disc_negated disc False m  (a. ¬ disc (Prot a)) 
     normalized_nnf_match m  compress_normalize_protocols m = Some m' 
     normalized_nnf_match m'  ¬ has_disc_negated disc False m'" (*original lemma allowed arbitrary neg*)
    apply(simp add: compress_normalize_protocols_def)
    apply(frule(2) import_protocols_from_ports_hasdisc_negated)
    using compress_normalize_protocols_step_hasdisc_negated by blast

  lemma compress_normalize_protocols_preserves_normalized_n_primitive:
    "normalized_n_primitive (disc, sel) P m  (a. ¬ disc (Prot a))  normalized_nnf_match m  compress_normalize_protocols m = Some m' 
     normalized_nnf_match m'  normalized_n_primitive (disc, sel) P m'"
    apply(simp add: compress_normalize_protocols_def)
    using import_protocols_from_ports_preserves_normalized_n_primitive
          compress_normalize_protocols_step_preserves_normalized_n_primitive by blast

  lemma "case compress_normalize_protocols 
    (MatchAnd (MatchAnd (MatchAnd (Match ((Prot (Proto TCP)):: 32 common_primitive)) (MatchNot (Match (Prot (Proto UDP))))) (Match (IIface (Iface ''eth1''))))
              (Match (Prot (Proto TCP)))) of Some ps  opt_MatchAny_match_expr ps
  =
  MatchAnd (Match (Prot (Proto 6))) (Match (IIface (Iface ''eth1'')))" by eval
  
  (*too many MatchAny!*)
  value[code] "compress_normalize_protocols (MatchAny:: 32 common_primitive match_expr)"


end

Theory Remdups_Rev

section‹Reverse Remdups›
theory Remdups_Rev
imports Main
begin

definition remdups_rev :: "'a list  'a list" where
  "remdups_rev rs  rev (remdups (rev rs))"

lemma remdups_append: "remdups (rs @ rs2) = remdups [rrs . r  set rs2] @ remdups rs2"
  by(induction rs arbitrary: rs2) (simp_all)

lemma remdups_rev_append: "remdups_rev (rs @ rs2) = remdups_rev rs @ remdups_rev [rrs2 . r  set rs]"
  proof(induction rs arbitrary: rs2)
  case Cons thus ?case by(simp add: remdups_append rev_filter remdups_rev_def)
  qed(simp add: remdups_rev_def)

lemma remdups_rev_fst:
  "remdups_rev (r#rs) = (if r  set rs then r#remdups_rev (removeAll r rs) else r#remdups_rev rs)"
proof -
  have 1: "r  set rs  remdups_rev (r # rs) = r # remdups_rev rs"
    unfolding remdups_rev_def
    proof(induction rs)
    case (Cons r rs)
      { fix rs and rs2::"'a list"
        have "set rs  set rs2 = {}  remdups (rs @ rs2) = remdups rs @ remdups rs2"
          by(induction rs arbitrary: rs2) (simp_all)
      } note h=this
      { fix r and rs::"'a list"
        from h[of "rev rs" "[r]"] have "r  set rs  remdups (rev rs @ [r]) = remdups (rev rs) @ [r]" by simp
      }
      with Cons show ?case by fastforce  
    qed(simp)

  have 2: "r  set rs  remdups_rev (r # rs) = r # remdups_rev (rev (removeAll r (rev rs)))"
    unfolding remdups_rev_def
    proof(induction rs)
    case Cons thus ?case
      apply(simp add: removeAll_filter_not_eq remdups_append)
      apply(safe)
        apply(simp_all)
       apply metis
      apply metis
      done
    qed(simp)

  have "rev (removeAll r (rev rs)) = removeAll r rs" by (simp add: removeAll_filter_not_eq rev_filter)
  with 1 2 show ?thesis by simp
qed

lemma remdups_rev_set: "set (remdups_rev rs) = set rs" by (simp add: remdups_rev_def) 

lemma remdups_rev_removeAll: "remdups_rev (removeAll r rs) = removeAll r (remdups_rev rs)"
  by (simp add: remdups_filter remdups_rev_def removeAll_filter_not_eq rev_filter)

text‹Faster code equations›
fun remdups_rev_code :: "'a list  'a list  'a list" where
  "remdups_rev_code _ [] = []" |
  "remdups_rev_code ps (r#rs) = (if r  set ps then remdups_rev_code ps rs else r#remdups_rev_code (r#ps) rs)"

lemma remdups_rev_code[code_unfold]: "remdups_rev rs = remdups_rev_code [] rs"
proof -
  { fix ps1 ps2 p and rs::"'a list"
    have "set ps1 = set ps2  remdups_rev_code ps1 rs = remdups_rev_code ps2 rs"
      proof(induction rs arbitrary: ps1 ps2)
      case Nil thus ?case by simp
      next
      case (Cons r rs) show ?case
        apply(subst remdups_rev_code.simps)+ (*simplifier loops*)
        apply(case_tac "r  set ps1")
         using Cons apply metis
        using Cons apply(simp)
        done
      qed
  } note remdups_rev_code_ps_seteq=this
  { fix ps1 ps2 p and rs::"'a list"
    have "remdups_rev_code (ps1@ps2) rs = remdups_rev_code ps2 (filter (λr. r  set ps1) rs)"
      proof(induction rs arbitrary: ps1 ps2)
      case (Cons r rs)
        have "remdups_rev_code (r # ps1 @ ps2) rs = remdups_rev_code (ps1 @ r # ps2) rs"
          by(rule remdups_rev_code_ps_seteq) simp
        with Cons.IH have "remdups_rev_code (r # ps1 @ ps2) rs = remdups_rev_code (r#ps2) [rrs . r  set ps1]" by simp
        from this show ?case by(simp add: Cons)
      qed(simp add: remdups_rev_def)
   } note remdups_rev_code_ps_append=this
  { fix ps p and rs::"'a list"
    have "remdups_rev_code (p # ps) rs = remdups_rev_code ps (removeAll p rs)"
      by(simp add: remdups_rev_code_ps_append[of "[p]" "ps" rs, simplified] removeAll_filter_not_eq) metis
  } note remdups_rev_code_ps_fst=this
  { fix ps p and rs::"'a list"
    have "remdups_rev_code ps (removeAll p rs) = removeAll p (remdups_rev_code ps rs)"
      apply(induction rs arbitrary: ps)
       apply(simp_all)
      apply(safe)
       apply(simp_all)
      apply(simp add: remdups_rev_code_ps_fst removeAll_filter_not_eq)
      done
  } note remdups_rev_code_removeAll=this
  {fix ps
    have "p  set ps. p  set rs  remdups_rev rs = remdups_rev_code ps rs"
      apply(induction rs arbitrary: ps)
       apply(simp add: remdups_rev_def)
      apply(simp add: remdups_rev_fst remdups_rev_removeAll)
      apply safe
        apply(simp_all)
       apply(simp add: remdups_rev_code_ps_fst remdups_rev_code_removeAll)
       apply metis
      by blast
  }
  thus ?thesis by simp
qed
  

end

Theory Ipassmt

theory Ipassmt
imports Common_Primitive_Syntax
        "../Semantics_Ternary/Primitive_Normalization"
        Simple_Firewall.Iface
        Simple_Firewall.IP_Addr_WordInterval_toString (*for debug pretty-printing*)
        Automatic_Refinement.Misc (*dependnecy!*)
begin
  hide_const Misc.uncurry
  hide_fact Misc.uncurry_def
    
  text‹A mapping from an interface to its assigned ip addresses in CIDR notation›
  type_synonym 'i ipassignment="iface  ('i word × nat) list" (*technically, a set*)


subsection‹Sanity checking for an @{typ "'i ipassignment"}.›

  text‹warning if interface map has wildcards›
  definition ipassmt_sanity_nowildcards :: "'i ipassignment  bool" where
    "ipassmt_sanity_nowildcards ipassmt   iface  dom ipassmt. ¬ iface_is_wildcard iface"

    text‹Executable of the @{typ "'i ipassignment"} is given as a list.›
    lemma[code_unfold]: "ipassmt_sanity_nowildcards (map_of ipassmt)  ( iface  fst` set ipassmt. ¬ iface_is_wildcard iface)"
      by(simp add: ipassmt_sanity_nowildcards_def Map.dom_map_of_conv_image_fst)
  
  lemma ipassmt_sanity_nowildcards_match_iface:
      "ipassmt_sanity_nowildcards ipassmt 
       ipassmt (Iface ifce2) = None 
       ipassmt ifce = Some a 
       ¬ match_iface ifce ifce2"
  unfolding ipassmt_sanity_nowildcards_def using iface_is_wildcard_def match_iface_case_nowildcard by fastforce


  (* use this in all exported code*)
  (*TODO: generate useful error message in exported code*)
  definition map_of_ipassmt :: "(iface × ('i word × nat) list) list  iface  ('i word × nat) list" where
    "map_of_ipassmt ipassmt = (
      if
        distinct (map fst ipassmt)  ipassmt_sanity_nowildcards (map_of ipassmt)
      then
        map_of ipassmt
      else undefined ⌦‹undefined_ipassmt_must_be_distinct_and_dont_have_wildcard_interfaces›)"


  text‹some additional (optional) sanity checks›
  
  text‹sanity check that there are no zone-spanning interfaces›
  definition ipassmt_sanity_disjoint :: "'i::len ipassignment  bool" where
    "ipassmt_sanity_disjoint ipassmt   i1  dom ipassmt.  i2  dom ipassmt. i1  i2 
          ipcidr_union_set (set (the (ipassmt i1)))  ipcidr_union_set (set (the (ipassmt i2))) = {}"
  
  lemma[code_unfold]: "ipassmt_sanity_disjoint (map_of ipassmt) 
    (let Is = fst` set ipassmt in 
      ( i1  Is.  i2  Is. i1  i2  wordinterval_empty (wordinterval_intersection (l2wi (map ipcidr_to_interval (the ((map_of ipassmt) i1))))  (l2wi (map ipcidr_to_interval (the ((map_of ipassmt) i2)))))))"
    apply(simp add: ipassmt_sanity_disjoint_def Map.dom_map_of_conv_image_fst)
    apply(simp add: ipcidr_union_set_def)
    apply(simp add: l2wi)
    apply(simp add: ipcidr_to_interval_def)
    using ipset_from_cidr_ipcidr_to_interval by blast
  
  
  text‹Checking that the ipassmt covers the complete ipv4 address space.›
  definition ipassmt_sanity_complete :: "(iface × ('i::len word × nat) list) list  bool" where
    "ipassmt_sanity_complete ipassmt  distinct (map fst ipassmt)  ((ipcidr_union_set ` set ` (ran (map_of ipassmt)))) = UNIV"

    lemma[code_unfold]: "ipassmt_sanity_complete ipassmt  distinct (map fst ipassmt)  (let range = map snd ipassmt in 
        wordinterval_eq (wordinterval_Union (map (l2wi  (map ipcidr_to_interval)) range)) wordinterval_UNIV
        )"
     apply(cases "distinct (map fst ipassmt)")
      apply(simp add: ipassmt_sanity_complete_def)
      apply(simp add: Map.ran_distinct)
      apply(simp add: wordinterval_eq_set_eq wordinterval_Union)
      apply(simp add: l2wi)
      apply(simp add: ipcidr_to_interval_def)
      apply(simp add: ipcidr_union_set_def ipset_from_cidr_ipcidr_to_interval; fail)
     apply(simp add: ipassmt_sanity_complete_def)
     done



    value[code] "ipassmt_sanity_nowildcards (map_of [(Iface ''eth1.1017'', [(ipv4addr_of_dotdecimal (131,159,14,240), 28)])])"

  fun collect_ifaces' :: "'i::len common_primitive rule list  iface list" where
    "collect_ifaces' [] = []" |
    "collect_ifaces' ((Rule m a)#rs) = filter (λiface. iface  ifaceAny) (
                                      (map (λx. case x of Pos i  i | Neg i  i) (fst (primitive_extractor (is_Iiface, iiface_sel) m))) @
                                      (map (λx. case x of Pos i  i | Neg i  i) (fst (primitive_extractor (is_Oiface, oiface_sel) m))) @ collect_ifaces' rs)"

  definition collect_ifaces :: "'i::len common_primitive rule list  iface list" where
    "collect_ifaces rs  mergesort_remdups (collect_ifaces' rs)"
  lemma "set (collect_ifaces rs) = set (collect_ifaces' rs)"
    by(simp add: collect_ifaces_def mergesort_remdups_correct)

  text‹sanity check that all interfaces mentioned in the ruleset are also listed in the ipassmt. May fail for wildcard interfaces in the ruleset.›

  (*primitive_extractor requires normalized_nnf_primitives*)
  definition ipassmt_sanity_defined :: "'i::len common_primitive rule list  'i ipassignment  bool" where
    "ipassmt_sanity_defined rs ipassmt   iface  set (collect_ifaces rs). iface  dom ipassmt"

    lemma[code]: "ipassmt_sanity_defined rs ipassmt  ( iface  set (collect_ifaces rs). ipassmt iface  None)"
      by(simp add: ipassmt_sanity_defined_def Map.domIff)
  
    lemma "ipassmt_sanity_defined [
         Rule (MatchAnd (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (192,168,0,0)) 24))) (Match (IIface (Iface ''eth1.1017'')))) action.Accept,
         Rule (MatchAnd (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (192,168,0,0)) 24))) (Match (IIface (ifaceAny)))) action.Accept,
         Rule MatchAny action.Drop]
             (map_of [(Iface ''eth1.1017'', [(ipv4addr_of_dotdecimal (131,159,14,240), 28)])])" by eval



  (*TODO: use and add code equation*)
  definition ipassmt_ignore_wildcard :: "'i::len ipassignment  'i ipassignment" where
    "ipassmt_ignore_wildcard ipassmt  λk. case ipassmt k of None  None 
                                                           | Some ips  if ipcidr_union_set (set ips) = UNIV then None else Some ips"

  lemma ipassmt_ignore_wildcard_le: "ipassmt_ignore_wildcard ipassmt m ipassmt"
    apply(simp add: ipassmt_ignore_wildcard_def map_le_def)
    apply(clarify)
    apply(simp split: option.split_asm if_split_asm)
    done

  definition ipassmt_ignore_wildcard_list:: "(iface × ('i::len word × nat) list) list  (iface × ('i word × nat) list) list" where
    "ipassmt_ignore_wildcard_list ipassmt = filter (λ(_,ips).  ¬ wordinterval_eq (l2wi (map ipcidr_to_interval ips)) wordinterval_UNIV) ipassmt"

  (*distinct fst ipassmt notwendig?*)
  lemma "distinct (map fst ipassmt) 
    map_of (ipassmt_ignore_wildcard_list ipassmt) = ipassmt_ignore_wildcard (map_of ipassmt)"
      apply(simp add: ipassmt_ignore_wildcard_list_def ipassmt_ignore_wildcard_def)
      apply(simp add: wordinterval_eq_set_eq)
      apply(simp add: l2wi)
      apply(simp add: ipcidr_to_interval_def)
      apply(simp add: fun_eq_iff)
      apply(clarify)
      apply(induction ipassmt)
       apply(simp; fail)
      apply(simp)
      apply(simp split:option.split option.split_asm)
      apply(simp add: ipcidr_union_set_def ipset_from_cidr_ipcidr_to_interval)
      apply(simp add: case_prod_unfold)
      by blast
      (*apply(safe)
                       apply(simp_all)
      by (simp add: rev_image_eqI)*)
      

  
  text‹Debug algorithm with human-readable output›
  definition debug_ipassmt_generic
    :: "('i::len wordinterval  string) 
          (iface × ('i word × nat) list) list  'i common_primitive rule list  string list" where
    "debug_ipassmt_generic toStr ipassmt rs  let ifaces = (map fst ipassmt) in [
      ''distinct: '' @ (if distinct ifaces then ''passed'' else ''FAIL!'')
      , ''ipassmt_sanity_nowildcards: '' @
          (if ipassmt_sanity_nowildcards (map_of ipassmt)
           then ''passed'' else ''fail: ''@list_toString iface_sel (filter iface_is_wildcard ifaces))
      , ''ipassmt_sanity_defined (interfaces defined in the ruleset are also in ipassmt): '' @ 
          (if ipassmt_sanity_defined rs (map_of ipassmt)
           then ''passed'' else ''fail: ''@list_toString iface_sel [i  (collect_ifaces rs). i  set ifaces])
      , ''ipassmt_sanity_disjoint (no zone-spanning interfaces): '' @
          (if ipassmt_sanity_disjoint (map_of ipassmt)
           then ''passed'' else ''fail: ''@list_toString (λ(i1,i2). ''('' @ iface_sel i1 @ '','' @ iface_sel i2 @ '')'')
               [(i1,i2)  List.product ifaces ifaces. i1  i2 
                ¬ wordinterval_empty (wordinterval_intersection
                                        (l2wi (map ipcidr_to_interval (the ((map_of ipassmt) i1))))
                                        (l2wi (map ipcidr_to_interval (the ((map_of ipassmt) i2)))))
          ])
      , ''ipassmt_sanity_disjoint excluding UNIV interfaces: '' @
          (let ipassmt = ipassmt_ignore_wildcard_list ipassmt;
               ifaces = (map fst ipassmt)
           in
          (if ipassmt_sanity_disjoint (map_of ipassmt)
           then ''passed'' else ''fail: ''@list_toString (λ(i1,i2). ''('' @ iface_sel i1 @ '','' @ iface_sel i2 @ '')'')
               [(i1,i2)  List.product ifaces ifaces. i1  i2 
                ¬ wordinterval_empty (wordinterval_intersection
                                        (l2wi (map ipcidr_to_interval (the ((map_of ipassmt) i1))))
                                        (l2wi (map ipcidr_to_interval (the ((map_of ipassmt) i2)))))
          ]))
       , ''ipassmt_sanity_complete: '' @ 
          (if ipassmt_sanity_complete ipassmt
           then ''passed''
           else ''the following is not covered: '' @ 
            toStr (wordinterval_setminus wordinterval_UNIV (wordinterval_Union (map (l2wi  (map ipcidr_to_interval)) (map snd ipassmt)))))
      , ''ipassmt_sanity_complete excluding UNIV interfaces: '' @
          (let ipassmt = ipassmt_ignore_wildcard_list ipassmt
           in
          (if ipassmt_sanity_complete ipassmt
           then ''passed''
           else ''the following is not covered: '' @
            toStr (wordinterval_setminus wordinterval_UNIV (wordinterval_Union (map (l2wi  (map ipcidr_to_interval)) (map snd ipassmt))))))
      ]"

  definition "debug_ipassmt_ipv4  debug_ipassmt_generic ipv4addr_wordinterval_toString"
  definition "debug_ipassmt_ipv6  debug_ipassmt_generic ipv6addr_wordinterval_toString"


  lemma dom_ipassmt_ignore_wildcard:
    "idom (ipassmt_ignore_wildcard ipassmt)  i  dom ipassmt  ipcidr_union_set (set (the (ipassmt i)))  UNIV"
    apply(simp add: ipassmt_ignore_wildcard_def)
    apply(rule)
     apply(clarify)
     apply(simp split: option.split_asm if_split_asm)
     apply blast
    apply(clarify)
    apply(simp)
    done

  lemma ipassmt_ignore_wildcard_the:
    "ipassmt i = Some ips  ipcidr_union_set (set ips)  UNIV  (the (ipassmt_ignore_wildcard ipassmt i)) = ips"
    "ipassmt_ignore_wildcard ipassmt i = Some ips  the (ipassmt i) = ips"
    "ipassmt_ignore_wildcard ipassmt i = Some ips  ipcidr_union_set (set ips)  UNIV"
    by (simp_all add: ipassmt_ignore_wildcard_def split: option.split_asm if_split_asm)
    

  lemma ipassmt_sanity_disjoint_ignore_wildcards:
        "ipassmt_sanity_disjoint (ipassmt_ignore_wildcard ipassmt) 
         (i1dom ipassmt.
          i2dom ipassmt.
            ipcidr_union_set (set (the (ipassmt i1)))  UNIV 
            ipcidr_union_set (set (the (ipassmt i2)))  UNIV 
            i1  i2 
             ipcidr_union_set (set (the (ipassmt i1)))  ipcidr_union_set (set (the (ipassmt i2))) = {})"
    apply(simp add: ipassmt_sanity_disjoint_def)
    apply(rule)
     apply(clarify)
     apply(simp)
     subgoal for i1 i2 ips1 ips2
     apply(erule_tac x=i1 in ballE)
      prefer 2
      using dom_ipassmt_ignore_wildcard  apply (metis domI option.sel)
     apply(erule_tac x=i2 in ballE)
      prefer 2
      using dom_ipassmt_ignore_wildcard apply (metis domI domIff option.sel)
     by(simp add: ipassmt_ignore_wildcard_the; fail)
    apply(clarify)
    apply(simp)
    subgoal for i1 i2 ips1 ips2
    apply(erule_tac x=i1 in ballE)
     prefer 2
     using dom_ipassmt_ignore_wildcard apply auto[1]
    apply(erule_tac x=i2 in ballE)
     prefer 2
     using dom_ipassmt_ignore_wildcard apply auto[1]
    by(simp add: ipassmt_ignore_wildcard_the)
   done

  text‹Confusing names: @{const ipassmt_sanity_nowildcards} refers to wildcard interfaces.
       @{const ipassmt_ignore_wildcard} refers to the UNIV ip range.
›
  lemma ipassmt_sanity_nowildcards_ignore_wildcardD:
    "ipassmt_sanity_nowildcards ipassmt  ipassmt_sanity_nowildcards (ipassmt_ignore_wildcard ipassmt)"
    by (simp add: dom_ipassmt_ignore_wildcard ipassmt_sanity_nowildcards_def)
    

 lemma ipassmt_disjoint_nonempty_inj:
     assumes ipassmt_disjoint: "ipassmt_sanity_disjoint ipassmt"
        and ifce: "ipassmt ifce = Some i_ips"
        and a: "ipcidr_union_set (set i_ips)  {}"
        and k: "ipassmt k = Some i_ips"
     shows "k = ifce"
     proof(rule ccontr)
       assume "k  ifce"
       with ifce k ipassmt_disjoint have "ipcidr_union_set (set (the (ipassmt k)))  ipcidr_union_set (set (the (ipassmt ifce))) = {}"
         unfolding ipassmt_sanity_disjoint_def by fastforce
       thus False using a ifce k by auto 
     qed

  lemma ipassmt_ignore_wildcard_None_Some:
    "ipassmt_ignore_wildcard ipassmt ifce = None  ipassmt ifce = Some ips  ipcidr_union_set (set ips) = UNIV"
    by (metis domI domIff dom_ipassmt_ignore_wildcard option.sel)
    

 (*can this lemma be somehow useful?
   maybe when rewriting, we can try to rewrite in the ignore_wildcard space and just constrain the the other area?*)
 lemma ipassmt_disjoint_ignore_wildcard_nonempty_inj:
     assumes ipassmt_disjoint: "ipassmt_sanity_disjoint (ipassmt_ignore_wildcard ipassmt)"
        and ifce: "ipassmt ifce = Some i_ips"
        and a: "ipcidr_union_set (set i_ips)  {}"
        and k: "(ipassmt_ignore_wildcard ipassmt) k = Some i_ips"
     shows "k = ifce"
     proof(rule ccontr)
       assume "k  ifce"
       show False
       proof(cases "(ipassmt_ignore_wildcard ipassmt) ifce")
       case (Some i_ips') (*proofs mainly by sledgehammer*)
         hence "i_ips' = i_ips" using ifce ipassmt_ignore_wildcard_the(2) by fastforce
         hence "(ipassmt_ignore_wildcard ipassmt) k = Some i_ips" using Some ifce ipassmt_ignore_wildcard_def k by auto 
         thus False using Some i_ips' = i_ips k  ifce a ipassmt_disjoint ipassmt_disjoint_nonempty_inj by blast
       next
       case None
         with ipassmt_ignore_wildcard_None_Some have "ipcidr_union_set (set i_ips) = UNIV" using ifce by auto 
         thus False using ipassmt_ignore_wildcard_the(3) k by blast 
       qed
     qed

 lemma ipassmt_disjoint_inj_k: 
     assumes ipassmt_disjoint: "ipassmt_sanity_disjoint ipassmt"
        and ifce: "ipassmt ifce = Some ips"
        and k: "ipassmt k = Some ips'"
        and a: "p  ipcidr_union_set (set ips)"
        and b: "p  ipcidr_union_set (set ips')"
     shows "k = ifce"
     proof(rule ccontr)
       assume "k  ifce"
       with ipassmt_disjoint have
          "ipcidr_union_set (set (the (ipassmt k)))  ipcidr_union_set (set (the (ipassmt ifce))) = {}"
         unfolding ipassmt_sanity_disjoint_def using ifce k by blast
       hence "ipcidr_union_set (set ips')  ipcidr_union_set (set ips) = {}" by(simp add: k ifce)
       thus False using a b by blast
     qed

 (*might also work when we ignore UNIVs in the ipassmt? (not tested)*)
 lemma ipassmt_disjoint_matcheq_iifce_srcip:
        assumes ipassmt_nowild: "ipassmt_sanity_nowildcards ipassmt"
            and ipassmt_disjoint: "ipassmt_sanity_disjoint ipassmt"
            and ifce: "ipassmt ifce = Some i_ips"
            and p_ifce: "ipassmt (Iface (p_iiface p)) = Some p_ips  p_src p  ipcidr_union_set (set p_ips)"
        shows   "match_iface ifce (p_iiface p)  p_src p  ipcidr_union_set (set i_ips)"
    proof
     assume "match_iface ifce (p_iiface p)"
     thus "p_src p  ipcidr_union_set (set i_ips)"
       apply(cases "ifce = Iface (p_iiface p)")
        using ifce p_ifce apply force
       by (metis domI iface.sel iface_is_wildcard_def ifce ipassmt_nowild ipassmt_sanity_nowildcards_def match_iface.elims(2) match_iface_case_nowildcard)
   next
     assume a: "p_src p  ipcidr_union_set (set i_ips)"
     ― ‹basically, we need to reverse the map @{term ipassmt}

     from ipassmt_disjoint_nonempty_inj[OF ipassmt_disjoint ifce] a have ipassmt_inj: "k. ipassmt k = Some i_ips  k = ifce" by blast

     from ipassmt_disjoint_inj_k[OF ipassmt_disjoint ifce _ a] have ipassmt_inj_k:
      "k ips'. ipassmt k = Some ips'  p_src p  ipcidr_union_set (set ips')  k = ifce" by simp

     have ipassmt_inj_p: "ips'. p_src p  ipcidr_union_set (set ips')  (k. ipassmt k = Some ips')  ips' = i_ips"
       apply(clarify)
       apply(rename_tac ips' k)
       apply(subgoal_tac "k = ifce")
        using ifce apply simp
       using ipassmt_inj_k by simp

     from p_ifce have "(Iface (p_iiface p)) = ifce" using ipassmt_inj_p ipassmt_inj by blast 

     thus "match_iface ifce (p_iiface p)" using match_iface_refl by blast 
   qed



  definition ipassmt_generic_ipv4 :: "(iface × (32 word × nat) list) list" where
    "ipassmt_generic_ipv4 = [(Iface ''lo'', [(ipv4addr_of_dotdecimal (127,0,0,0),8)])]"

  definition ipassmt_generic_ipv6 :: "(iface × (128 word × nat) list) list" where
    "ipassmt_generic_ipv6 = [(Iface ''lo'', [(1,128)])]" (*::1/128*)



subsection‹IP Assignment difference›
  text‹Compare two ipassmts. Returns a list of tuples
    First entry of the tuple: things which are in the left ipassmt but not in the right.
    Second entry of the tupls: things which are in the right ipassmt but not in the left.›
  definition ipassmt_diff
    :: "(iface × ('i::len word × nat) list) list  (iface × ('i::len word × nat) list) list
         (iface × ('i word × nat) list × ('i word × nat) list) list"
  where
  "ipassmt_diff a b  let
      t = λs. (case s of None  Empty_WordInterval
                       | Some s  wordinterval_Union (map ipcidr_tuple_to_wordinterval s));
      k = λx y d. cidr_split (wordinterval_setminus (t (map_of x d)) (t (map_of y d)))
    in
      [(d, (k a b d, k b a d)). d  remdups (map fst (a @ b))]"
  
  
  text‹If an interface is defined in both ipassignments and there is no difference
       then the two ipassignements describe the same IP range for this interface.›
  lemma ipassmt_diff_ifce_equal: "(ifce, [], [])  set (ipassmt_diff ipassmt1 ipassmt2)  
         ifce  dom (map_of ipassmt1)  ifce  dom (map_of ipassmt2) 
           ipcidr_union_set (set (the ((map_of ipassmt1) ifce))) =
           ipcidr_union_set (set (the ((map_of ipassmt2) ifce)))"
    proof -
    have cidr_empty: "[] = cidr_split r  wordinterval_to_set r = {}" for r :: "'a wordinterval"
      apply(subst cidr_split_prefix[symmetric])
      by(simp)
    show "(ifce, [], [])  set (ipassmt_diff ipassmt1 ipassmt2)  
         ifce  dom (map_of ipassmt1)  ifce  dom (map_of ipassmt2) 
           ipcidr_union_set (set (the ((map_of ipassmt1) ifce))) =
           ipcidr_union_set (set (the ((map_of ipassmt2) ifce)))"
    apply(simp add: ipassmt_diff_def Let_def ipcidr_union_set_uncurry)
    apply(simp add: Set.image_iff)
    apply(elim conjE)
    apply(drule cidr_empty)+
    apply(simp)
    apply(simp add: domIff)
    apply(elim exE)
    apply(simp add: wordinterval_Union wordinterval_to_set_ipcidr_tuple_to_wordinterval_uncurry)
    done
  qed

  lemma ipcidr_union_cidr_split[simp]: "ipcidr_union_set (set (cidr_split a)) = wordinterval_to_set a"
    by(simp add: ipcidr_union_set_uncurry cidr_split_prefix)

  lemma 
    defines "assmt as ifce  ipcidr_union_set (set (the ((map_of as ifce))))"
    assumes diffs: "(ifce, d1, d2)  set (ipassmt_diff ipassmt1 ipassmt2)"
        and  doms: "ifce  dom (map_of ipassmt1)" "ifce  dom (map_of ipassmt2)"
    shows "ipcidr_union_set (set d1) = assmt ipassmt1 ifce - assmt ipassmt2 ifce"
          "ipcidr_union_set (set d2) = assmt ipassmt2 ifce - assmt ipassmt1 ifce"
    using assms by (clarsimp simp add: ipassmt_diff_def Let_def assmt_def wordinterval_Union; simp add: ipcidr_union_set_uncurry uncurry_def wordinterval_to_set_ipcidr_tuple_to_wordinterval_uncurry)+
            
  
  text‹Explanation for interface @{term "Iface ''a''"}: 
          Left ipassmt: The IP range 4/30 contains the addresses 4,5,6,7
          Diff: right ipassmt contains 6/32, so 4,5,7 is only in the left ipassmt.
          IP addresses 4,5 correspond to subnet 4/30.›
  lemma "ipassmt_diff (ipassmt_generic_ipv4 @ [(Iface ''a'', [(4,30)])])
                       (ipassmt_generic_ipv4 @ [(Iface ''a'', [(6,32), (0,30)]), (Iface ''b'', [(42,32)])]) =
    [(Iface ''lo'', [], []),
     (Iface ''a'', [(4, 31),(7, 32)],
                   [(0, 30)]
     ),
     (Iface ''b'', [], [(42, 32)])]" by eval

end

Theory No_Spoof

theory No_Spoof
imports Common_Primitive_Lemmas
        Ipassmt
begin

section‹No Spoofing›
(* we do this in ternary (not simple firewall) to support negated interfaces *)
  text‹assumes: @{const simple_ruleset}


subsection‹Spoofing Protection›
  text‹
  No spoofing means:
  Every packet that is (potentially) allowed by the firewall and comes from an interface iface› 
  must have a Source IP Address in the assigned range iface›.
  
  ``potentially allowed'' means we use the upper closure.
  The definition states: For all interfaces which are configured, every packet that comes from this
  interface and is allowed by the firewall must be in the IP range of that interface.
›


text‹We add @{typ "'pkt_ext itself"} as a parameter to have the type of a generic, extensible packet
     in the definition.›
  definition no_spoofing :: "'pkt_ext itself  'i::len ipassignment  'i::len common_primitive rule list  bool" where
    "no_spoofing TYPE('pkt_ext) ipassmt rs   iface  dom ipassmt. p :: ('i,'pkt_ext) tagged_packet_scheme.
        ((common_matcher, in_doubt_allow),pp_iiface:=iface_sel iface rs, Undecided α Decision FinalAllow) 
            p_src p  (ipcidr_union_set (set (the (ipassmt iface))))"

  text ‹This is how it looks like for an IPv4 simple packet: We add @{type unit} because a
        @{typ "32 tagged_packet"} does not have any additional fields.›
  lemma "no_spoofing TYPE(unit) ipassmt rs 
    ( iface  dom ipassmt. p :: 32 tagged_packet.
      ((common_matcher, in_doubt_allow),pp_iiface:=iface_sel iface rs, Undecided α Decision FinalAllow)
          p_src p  (ipcidr_union_set (set (the (ipassmt iface)))))"
    unfolding no_spoofing_def by blast

  text‹The definition is sound (if that can be said about a definition):
          if @{const no_spoofing} certifies your ruleset, then your ruleset prohibits spoofing.
         The definition may not be complete:
          @{const no_spoofing} may return @{const False} even though your ruleset prevents spoofing
          (should only occur if some strange and unknown primitives occur)›

  text‹Technical note: The definition can can be thought of as protection from OUTGOING spoofing.
        OUTGOING means: I define my interfaces and their IP addresses. For all interfaces,
                        only the assigned IP addresses may pass the firewall.
                        This definition is simple for e.g. local sub-networks.
                        Example: @{term "[Iface ''eth0''  {(ipv4addr_of_dotdecimal (192,168,0,0), 24)}]"}

        If I want spoofing protection from the Internet, I need to specify the range of the Internet IP addresses.
        Example: @{term "[Iface ''evil_internet''  {everything_that_does_not_belong_to_me}]"}.
          This is also a good opportunity to exclude the private IP space, link local, and probably multicast space.
        See @{const all_but_those_ips} to easily specify these ranges.

        See examples below. Check Example 3 why it can be thought of as OUTGOING spoofing.›



(*
and now code to check spoofing protection
*)
context
begin
  text‹The set of any ip addresses which may match for a fixed iface› (overapproximation)›
  private definition get_exists_matching_src_ips :: "iface  'i::len common_primitive match_expr  'i word set" where
    "get_exists_matching_src_ips iface m  let (i_matches, _) = (primitive_extractor (is_Iiface, iiface_sel) m) in
              if ( is  set i_matches. (case is of Pos i  match_iface i (iface_sel iface)
                                                  | Neg i  ¬ match_iface i (iface_sel iface)))
              then
                (let (ip_matches, _) = (primitive_extractor (is_Src, src_sel) m) in
                if ip_matches = []
                then
                  UNIV
                else
                   ips  set (ip_matches). (case ips of Pos ip  ipt_iprange_to_set ip | Neg ip  - ipt_iprange_to_set ip))
              else
                {}"

  (*when we replace the set by a 32 wordinterval, we should get executable code*)
  lemma "primitive_extractor (is_Src, src_sel)
      (MatchAnd (Match (Src (IpAddrNetmask (0::ipv4addr) 30))) (Match (IIface (Iface ''eth0'')))) =
      ([Pos (IpAddrNetmask 0 30)], MatchAnd MatchAny (Match (IIface (Iface ''eth0''))))" by eval

 private lemma get_exists_matching_src_ips_subset: 
    assumes "normalized_nnf_match m"
    shows "{ip. (p :: ('i::len, 'a) tagged_packet_scheme. matches (common_matcher, in_doubt_allow) m a (pp_iiface:= iface_sel iface, p_src:= ip))} 
           get_exists_matching_src_ips iface m"
  proof -
    let ="(common_matcher, in_doubt_allow)"

    { fix ip_matches rest src_ip i_matches rest2 and p :: "('i, 'a) tagged_packet_scheme"
      assume a1: "primitive_extractor (is_Src, src_sel) m = (ip_matches, rest)"
      and a2: "matches  m a (pp_iiface := iface_sel iface, p_src := src_ip)"
      let ?p="(pp_iiface := iface_sel iface, p_src := src_ip)"

      from primitive_extractor_negation_type_matching1[OF wf_disc_sel_common_primitive(3) assms a1 a2]
           match_simplematcher_SrcDst[where p = ?p] match_simplematcher_SrcDst_not[where p="?p"]
       have ip_matches: "(ipset (getPos ip_matches). p_src ?p  ipt_iprange_to_set ip) 
                         (ipset (getNeg ip_matches). p_src ?p  - ipt_iprange_to_set ip)" by simp
      from ip_matches have "x  set ip_matches. src_ip  (case x of Pos x  ipt_iprange_to_set x | Neg ip  - ipt_iprange_to_set ip)"
        apply(simp)
        apply(simp  split: negation_type.split)
        apply(safe)
         using NegPos_set apply fast+
      done
    } note 1=this

    { fix ip_matches rest src_ip i_matches rest2 and p :: "('i, 'a) tagged_packet_scheme"
      assume a1: "primitive_extractor (is_Iiface, iiface_sel) m = (i_matches, rest2)"
         and a2: "matches  m a (pp_iiface := iface_sel iface, p_src := src_ip)"
      let ?p="(pp_iiface := iface_sel iface, p_src := src_ip)"
    
      from primitive_extractor_negation_type_matching1[OF wf_disc_sel_common_primitive(5) assms a1 a2]
           primitive_matcher_generic.Iface_single[OF primitive_matcher_generic_common_matcher, where p = ?p]
           primitive_matcher_generic.Iface_single_not[OF primitive_matcher_generic_common_matcher, where p = ?p]
      have iface_matches: "(iset (getPos i_matches). match_iface i (p_iiface ?p)) 
                           (iset (getNeg i_matches). ¬ match_iface i (p_iiface ?p))" by simp
      hence 2: "(xset i_matches. case x of Pos i  match_iface i (iface_sel iface) | Neg i  ¬ match_iface i (iface_sel iface))"
        apply(simp add: split: negation_type.split)
        apply(safe)
        using NegPos_set apply fast+
      done
      
    } note 2=this

    from 1 2 show ?thesis
      unfolding get_exists_matching_src_ips_def
      by(clarsimp)
  qed


  lemma common_primitive_not_has_primitive_expand: 
        "¬ has_primitive (m::'i::len common_primitive match_expr) 
         ¬ has_disc is_Dst m  
         ¬ has_disc is_Src m 
         ¬ has_disc is_Iiface m 
         ¬ has_disc is_Oiface m 
         ¬ has_disc is_Prot m 
         ¬ has_disc is_Src_Ports m 
         ¬ has_disc is_Dst_Ports m 
         ¬ has_disc is_MultiportPorts m 
         ¬ has_disc is_L4_Flags m 
         ¬ has_disc is_CT_State m 
         ¬ has_disc is_Extra m"
  apply(induction m)
     apply(simp_all)
    apply(rename_tac x, case_tac x, simp_all)
   by blast

 
  (*matcheq_matchAny is undefined for primitives. this is the proper way to call it!*)
  lemma "¬ has_primitive m  matcheq_matchAny m  (if ¬ has_primitive m then matcheq_matchAny m else False)"
    by simp

  text‹The set of ip addresses which definitely match for a fixed iface› (underapproximation)›
  private definition get_all_matching_src_ips :: "iface  'i::len common_primitive match_expr  'i word set" where
    "get_all_matching_src_ips iface m  let (i_matches, rest1) = (primitive_extractor (is_Iiface, iiface_sel) m) in
              if ( is  set i_matches. (case is of Pos i  match_iface i (iface_sel iface)
                                                  | Neg i  ¬ match_iface i (iface_sel iface)))
              then
                (let (ip_matches, rest2) = (primitive_extractor (is_Src, src_sel) rest1) in
                if ¬ has_primitive rest2  matcheq_matchAny rest2
                then
                  if ip_matches = []
                  then
                    UNIV
                  else
                     ips  set (ip_matches). (case ips of Pos ip  ipt_iprange_to_set ip | Neg ip  - ipt_iprange_to_set ip)
                else
                  {})
              else
                {}"



 private lemma get_all_matching_src_ips: 
    assumes "normalized_nnf_match m"
    shows "get_all_matching_src_ips iface m 
            {ip. (p::('i::len, 'a) tagged_packet_scheme. matches (common_matcher, in_doubt_allow) m a (pp_iiface:= iface_sel iface, p_src:= ip))}"
  proof 
    fix ip
    assume a: "ip  get_all_matching_src_ips iface m" 
    obtain i_matches rest1 where select1: "primitive_extractor (is_Iiface, iiface_sel) m = (i_matches, rest1)" by fastforce
    show "ip  {ip. p :: ('i, 'a) tagged_packet_scheme. matches (common_matcher, in_doubt_allow) m a (pp_iiface := iface_sel iface, p_src := ip)}"
    proof(cases " is  set i_matches. (case is of Pos i  match_iface i (iface_sel iface)
                                                 | Neg i  ¬match_iface i (iface_sel iface))")
    case False
      have "get_all_matching_src_ips iface m = {}"
        unfolding get_all_matching_src_ips_def
        using select1 False by auto
      with a show ?thesis by simp
    next
    case True
      let ="(common_matcher, in_doubt_allow) :: ('i::len common_primitive, ('i, 'a) tagged_packet_scheme) match_tac"
      let ?p="λp::('i, 'a) tagged_packet_scheme. pp_iiface := iface_sel iface, p_src := ip"
      obtain ip_matches rest2 where select2: "primitive_extractor (is_Src, src_sel) rest1 = (ip_matches, rest2)" by fastforce

      let ?noDisc="¬ has_primitive rest2"

      have get_all_matching_src_ips_caseTrue: "get_all_matching_src_ips iface m =
            (if ?noDisc  matcheq_matchAny rest2
             then if ip_matches = []
                  then UNIV
                  else ((case_negation_type ipt_iprange_to_set (λip. - ipt_iprange_to_set ip) ` (set ip_matches)))
              else {})"
      unfolding get_all_matching_src_ips_def
      by(simp add: True select1 select2)

      from True have "(mset (getPos i_matches). matches  (Match (IIface m)) a (?p p)) 
                      (mset (getNeg i_matches). matches  (MatchNot (Match (IIface m))) a (?p p))"
       for p :: "('i, 'a) tagged_packet_scheme"
        by(simp add: negation_type_forall_split
            primitive_matcher_generic.Iface_single[OF primitive_matcher_generic_common_matcher]
            primitive_matcher_generic.Iface_single_not[OF primitive_matcher_generic_common_matcher])
      hence matches_iface: "matches  (alist_and (NegPos_map IIface i_matches)) a (?p p)"
        for p :: "('i,'a) tagged_packet_scheme"
        by(simp add: matches_alist_and NegPos_map_simps)

      show ?thesis
      proof(cases "?noDisc  matcheq_matchAny rest2")
      case False
        assume F: "¬ (?noDisc  matcheq_matchAny rest2)"
        with get_all_matching_src_ips_caseTrue have "get_all_matching_src_ips iface m = {}" by presburger
        with a have False by simp
        thus ?thesis ..
      next
      case True
        assume F: "?noDisc  matcheq_matchAny rest2"
        with get_all_matching_src_ips_caseTrue have "get_all_matching_src_ips iface m = 
            (if ip_matches = []
             then UNIV
             else ((case_negation_type ipt_iprange_to_set (λip. - ipt_iprange_to_set ip) ` (set ip_matches))))" by presburger

        from primitive_extractor_correct[OF assms wf_disc_sel_common_primitive(5) select1] have
          select1_matches: "matches  (alist_and (NegPos_map IIface i_matches)) a p  matches  rest1 a p  matches  m a p"
          and normalized1: "normalized_nnf_match rest1" for p :: "('i,'a) tagged_packet_scheme"
          apply -
            apply fast+
          done
        from select1_matches matches_iface have
          rest1_matches: "matches  rest1 a (?p p)  matches  m a (?p p)" for p :: "('i, 'a) tagged_packet_scheme" by blast

        from primitive_extractor_correct[OF normalized1 wf_disc_sel_common_primitive(3) select2] have
          select2_matches: "matches  (alist_and (NegPos_map Src ip_matches)) a p  matches  rest2 a p  
                            matches  rest1 a p" for p :: "('i, 'a) tagged_packet_scheme"
        by fast
        with F matcheq_matchAny have "matches  rest2 a p" for p :: "('i, 'a) tagged_packet_scheme" by metis
        with select2_matches rest1_matches have ip_src_matches: 
          "matches  (alist_and (NegPos_map Src ip_matches)) a (?p p)  matches  m a (?p p)"
          for p :: "('i, 'a) tagged_packet_scheme" by simp

        have case_nil: "p. ip_matches = []  matches  (alist_and (NegPos_map Src ip_matches)) a p"
          by(simp add: bunch_of_lemmata_about_matches)

        have case_list: "p. xset ip_matches. (case x of Pos i  ip  ipt_iprange_to_set i
                                                          | Neg i  ip  - ipt_iprange_to_set i) 
            matches  (alist_and (NegPos_map Src ip_matches)) a (pp_iiface := iface_sel iface, p_src := ip)"
          apply(simp add: matches_alist_and NegPos_map_simps)
          apply(simp add: negation_type_forall_split match_simplematcher_SrcDst_not match_simplematcher_SrcDst)
          done

        from a show "ip  {ip. p :: ('i, 'a) tagged_packet_scheme. matches (common_matcher, in_doubt_allow) m a (pp_iiface := iface_sel iface, p_src := ip)}"
          unfolding get_all_matching_src_ips_caseTrue
          proof(clarsimp split: if_split_asm)
            fix p :: "('i, 'a) tagged_packet_scheme"
            assume "ip_matches = []"
            with case_nil have "matches  (alist_and (NegPos_map Src ip_matches)) a (?p p)" by simp
            with ip_src_matches show "matches  m a (?p p)" by simp
          next
            fix p :: "('i, 'a) tagged_packet_scheme"
            assume "xset ip_matches. ip  (case x of Pos x  ipt_iprange_to_set x | Neg ip  - ipt_iprange_to_set ip)"
            hence "xset ip_matches. case x of Pos i  ip  ipt_iprange_to_set i | Neg i  ip  - ipt_iprange_to_set i"
             by(simp_all split: negation_type.split negation_type.split_asm)
            with case_list have "matches  (alist_and (NegPos_map Src ip_matches)) a (?p p)" .
            with ip_src_matches show "matches  m a (?p p)" by simp
          qed
       qed
     qed
  qed



  private definition get_exists_matching_src_ips_executable
    :: "iface  'i::len common_primitive match_expr  'i wordinterval" where
    "get_exists_matching_src_ips_executable iface m  let (i_matches, _) = (primitive_extractor (is_Iiface, iiface_sel) m) in
              if ( is  set i_matches. (case is of Pos i  match_iface i (iface_sel iface)
                                                  | Neg i  ¬match_iface i (iface_sel iface)))
              then
                (let (ip_matches, _) = (primitive_extractor (is_Src, src_sel) m) in
                if ip_matches = []
                then
                  wordinterval_UNIV
                else
                  l2wi_negation_type_intersect (NegPos_map ipt_iprange_to_interval ip_matches))
              else
                Empty_WordInterval"
  (*WOW, such horrible proof!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!*)
  lemma get_exists_matching_src_ips_executable: 
    "wordinterval_to_set (get_exists_matching_src_ips_executable iface m) = get_exists_matching_src_ips iface m"
    apply(simp add: get_exists_matching_src_ips_executable_def get_exists_matching_src_ips_def)
    apply(case_tac "primitive_extractor (is_Iiface, iiface_sel) m")
    apply(case_tac "primitive_extractor (is_Src, src_sel) m")
    apply(simp)
    apply(simp add: l2wi_negation_type_intersect)
    apply(simp add: NegPos_map_simps)
    apply(safe)
         apply(simp_all add: ipt_iprange_to_interval)
      apply(rename_tac i_matches rest1 a b x xa)
      apply(case_tac xa)
       apply(simp_all add: NegPos_set)
       using ipt_iprange_to_interval apply fast+
     apply(rename_tac i_matches rest1 a b x aa ab ba)
     apply(erule_tac x="Pos aa" in ballE)
      apply(simp_all add: NegPos_set)
    using NegPos_set(2) by fastforce

  lemma "(get_exists_matching_src_ips_executable (Iface ''eth0'')
      (MatchAnd (MatchNot (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (192,168,0,0)) 24)))) (Match (IIface (Iface ''eth0''))))) =
      RangeUnion (WordInterval 0 0xC0A7FFFF) (WordInterval 0xC0A80100 0xFFFFFFFF)" by eval

  private definition get_all_matching_src_ips_executable
    :: "iface  'i::len common_primitive match_expr  'i wordinterval" where
    "get_all_matching_src_ips_executable iface m  let (i_matches, rest1) = (primitive_extractor (is_Iiface, iiface_sel) m) in
              if ( is  set i_matches. (case is of Pos i  match_iface i (iface_sel iface)
                                                  | Neg i  ¬match_iface i (iface_sel iface)))
              then
                (let (ip_matches, rest2) = (primitive_extractor (is_Src, src_sel) rest1) in
                if ¬ has_primitive rest2  matcheq_matchAny rest2
                then
                  if ip_matches = []
                  then
                    wordinterval_UNIV
                  else
                    l2wi_negation_type_intersect (NegPos_map ipt_iprange_to_interval ip_matches)
                else
                  Empty_WordInterval)
              else
                Empty_WordInterval"
  (*WOW, such horrible proof!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!*)
  lemma get_all_matching_src_ips_executable: 
    "wordinterval_to_set (get_all_matching_src_ips_executable iface m) = get_all_matching_src_ips iface m"
    apply(simp add: get_all_matching_src_ips_executable_def get_all_matching_src_ips_def)
    apply(case_tac "primitive_extractor (is_Iiface, iiface_sel) m")
    apply(simp, rename_tac i_matches rest1)
    apply(case_tac "primitive_extractor (is_Src, src_sel) rest1")
    apply(simp)
    apply(simp add: l2wi_negation_type_intersect)
    apply(simp add: NegPos_map_simps)
    apply(safe)
         apply(simp_all add: ipt_iprange_to_interval)
      apply(rename_tac i_matches rest1 a b x xa)
      apply(case_tac xa)
       apply(simp_all add: NegPos_set)
       using ipt_iprange_to_interval apply fast+
     apply(rename_tac i_matches rest1 a b x aa ab ba)
     apply(erule_tac x="Pos aa" in ballE)
      apply(simp_all add: NegPos_set)
    apply(erule_tac x="Neg aa" in ballE)
     apply(simp_all add: NegPos_set)
    done
  lemma "(get_all_matching_src_ips_executable (Iface ''eth0'')
      (MatchAnd (MatchNot (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (192,168,0,0)) 24)))) (Match (IIface (Iface ''eth0''))))) = 
      RangeUnion (WordInterval 0 0xC0A7FFFF) (WordInterval 0xC0A80100 0xFFFFFFFF)" by eval

     

  text‹The following algorithm sound but not complete.›
  (*alowed: set ip ips potentially allowed for iface
    denied: set of ips definitely dropped for iface*)
  private fun no_spoofing_algorithm
    :: "iface  'i::len ipassignment  'i common_primitive rule list  'i word set  'i word set  bool" where
    "no_spoofing_algorithm iface ipassmt [] allowed denied1   
      (allowed - denied1)  ipcidr_union_set (set (the (ipassmt iface)))" |
    "no_spoofing_algorithm iface ipassmt ((Rule m Accept)#rs) allowed denied1 = no_spoofing_algorithm iface ipassmt rs 
        (allowed  get_exists_matching_src_ips iface m) denied1" |
    "no_spoofing_algorithm iface ipassmt ((Rule m Drop)#rs) allowed denied1 = no_spoofing_algorithm iface ipassmt rs
         allowed (denied1  (get_all_matching_src_ips iface m - allowed))"  |
    "no_spoofing_algorithm _ _ _ _ _  = undefined"



  private fun no_spoofing_algorithm_executable
    :: "iface  (iface  ('i::len word × nat) list)  'i common_primitive rule list
           'i wordinterval  'i wordinterval  bool" where
    "no_spoofing_algorithm_executable iface ipassmt [] allowed denied1   
      wordinterval_subset (wordinterval_setminus allowed denied1) (l2wi (map ipcidr_to_interval (the (ipassmt iface))))" |
    "no_spoofing_algorithm_executable iface ipassmt ((Rule m Accept)#rs) allowed denied1 = no_spoofing_algorithm_executable iface ipassmt rs 
        (wordinterval_union allowed (get_exists_matching_src_ips_executable iface m)) denied1" |
    "no_spoofing_algorithm_executable iface ipassmt ((Rule m Drop)#rs) allowed denied1 = no_spoofing_algorithm_executable iface ipassmt rs
         allowed (wordinterval_union denied1 (wordinterval_setminus (get_all_matching_src_ips_executable iface m) allowed))"  |
    "no_spoofing_algorithm_executable _ _ _ _ _  = undefined"

  lemma no_spoofing_algorithm_executable: "no_spoofing_algorithm_executable iface ipassmt rs allowed denied  
         no_spoofing_algorithm iface ipassmt rs (wordinterval_to_set allowed) (wordinterval_to_set denied)"
  proof(induction iface ipassmt rs allowed denied rule: no_spoofing_algorithm_executable.induct)
  case (1 iface ipassmt allowed denied1)
    have "(aset (the (ipassmt iface)). case ipcidr_to_interval a of (x, xa)  {x..xa}) = 
          (xset (the (ipassmt iface)). uncurry ipset_from_cidr x)"
    by(simp add: ipcidr_to_interval_def uncurry_def ipset_from_cidr_ipcidr_to_interval)
    with 1 show ?case by(simp add: ipcidr_union_set_uncurry l2wi)
  next
  case 2 thus ?case by(simp add: get_exists_matching_src_ips_executable get_all_matching_src_ips_executable)
  next
  case 3 thus ?case by(simp add: get_exists_matching_src_ips_executable get_all_matching_src_ips_executable)
  qed(simp_all)


  private definition "nospoof TYPE('pkt_ext) iface ipassmt rs = (p :: ('i::len,'pkt_ext) tagged_packet_scheme.
          (approximating_bigstep_fun (common_matcher, in_doubt_allow) (pp_iiface:=iface_sel iface) rs Undecided = Decision FinalAllow) 
              p_src p  (ipcidr_union_set (set (the (ipassmt iface)))))"
  private definition "setbydecision TYPE('pkt_ext) iface rs dec = {ip. p :: ('i::len,'pkt_ext) tagged_packet_scheme. approximating_bigstep_fun (common_matcher, in_doubt_allow) 
                           (pp_iiface:=iface_sel iface, p_src := ip) rs Undecided = Decision dec}"

  private lemma nospoof_setbydecision:
    fixes rs :: "'i::len common_primitive rule list"
    shows "nospoof TYPE('pkt_ext) iface ipassmt rs  
          setbydecision TYPE('pkt_ext) iface rs FinalAllow  (ipcidr_union_set (set (the (ipassmt iface))))"
  proof
    assume a: "nospoof TYPE('pkt_ext) iface ipassmt rs"
    have packet_update_iface_simp: "pp_iiface := iface_sel iface, p_src := x = pp_src := x, p_iiface := iface_sel iface"
      for p::"('i::len, 'p) tagged_packet_scheme" and x by simp
 
    from a show "setbydecision TYPE('pkt_ext) iface rs FinalAllow  ipcidr_union_set (set (the (ipassmt iface)))"
      apply(simp add: nospoof_def setbydecision_def)
      apply(safe)
      apply(rename_tac x p)
      apply(erule_tac x="pp_iiface := iface_sel iface, p_src := x" in allE)
      apply(simp)
      apply(simp add: packet_update_iface_simp)
      done
  next
    assume a1: "setbydecision TYPE('pkt_ext) iface rs FinalAllow  ipcidr_union_set (set (the (ipassmt iface)))"
    show "nospoof TYPE('pkt_ext) iface ipassmt rs"
      unfolding nospoof_def
      proof(safe)
        fix p :: "('i::len,'pkt_ext) tagged_packet_scheme"
        assume a2: "approximating_bigstep_fun (common_matcher, in_doubt_allow) (pp_iiface := iface_sel iface) rs Undecided = Decision FinalAllow"
        ― ‹In @{text setbydecision_fix_p}the @{text } quantifier is gone and we consider this set for @{term p}.›
        let ?setbydecision_fix_p="{ip. approximating_bigstep_fun (common_matcher, in_doubt_allow) 
          (pp_iiface := iface_sel iface, p_src := ip) rs Undecided = Decision FinalAllow}"
        from a1 a2 have 1: "?setbydecision_fix_p  ipcidr_union_set (set (the (ipassmt iface)))" by(simp add: nospoof_def setbydecision_def) blast
        from a2 have 2: "p_src p  ?setbydecision_fix_p" by simp
        from 1 2 show "p_src p  ipcidr_union_set (set (the (ipassmt iface)))" by blast
      qed
  qed


  private definition "setbydecision_all TYPE('pkt_ext) iface rs dec = {ip. p :: ('i::len,'pkt_ext) tagged_packet_scheme.
    approximating_bigstep_fun (common_matcher, in_doubt_allow) (pp_iiface:=iface_sel iface, p_src := ip) rs Undecided = Decision dec}"

  private lemma setbydecision_setbydecision_all_Allow: 
    "(setbydecision TYPE('pkt_ext) iface rs FinalAllow - setbydecision_all TYPE('pkt_ext) iface rs FinalDeny) = 
      setbydecision TYPE('pkt_ext) iface rs FinalAllow"
    apply(safe)
    apply(simp add: setbydecision_def setbydecision_all_def)
    done
  private lemma setbydecision_setbydecision_all_Deny: 
    "(setbydecision TYPE('pkt_ext) iface rs FinalDeny - setbydecision_all TYPE('pkt_ext) iface rs FinalAllow) = 
      setbydecision TYPE('pkt_ext) iface rs FinalDeny"
    apply(safe)
    apply(simp add: setbydecision_def setbydecision_all_def)
    done

  private lemma setbydecision_append:
    "simple_ruleset (rs1 @ rs2) 
      setbydecision TYPE('pkt_ext) iface (rs1 @ rs2) FinalAllow =
        setbydecision TYPE('pkt_ext) iface rs1 FinalAllow  {ip. p :: ('i::len,'pkt_ext) tagged_packet_scheme. approximating_bigstep_fun (common_matcher, in_doubt_allow) 
         (pp_iiface:=iface_sel iface, p_src := ip) rs2 Undecided = Decision FinalAllow 
          approximating_bigstep_fun (common_matcher, in_doubt_allow) (pp_iiface:=iface_sel iface, p_src := ip) rs1 Undecided = Undecided}"
      apply(simp add: setbydecision_def)
      apply(subst Set.Collect_disj_eq[symmetric])
      apply(rule Set.Collect_cong)
      apply(subst approximating_bigstep_fun_seq_Undecided_t_wf)
       apply(simp add: simple_imp_good_ruleset good_imp_wf_ruleset)
      by blast

  private lemma not_FinalAllow: "foo  Decision FinalAllow  foo = Decision FinalDeny  foo = Undecided"
    apply(cases foo)
     apply simp_all
    apply(rename_tac x2)
    apply(case_tac x2)
     apply(simp_all)
    done

  private lemma setbydecision_all_appendAccept: "simple_ruleset (rs @ [Rule r Accept])  
    setbydecision_all TYPE('pkt_ext) iface rs FinalDeny = setbydecision_all TYPE('pkt_ext) iface (rs @ [Rule r Accept]) FinalDeny"
      apply(simp add: setbydecision_all_def)
      apply(rule Set.Collect_cong)
      apply(subst approximating_bigstep_fun_seq_Undecided_t_wf)
       apply(simp add: simple_imp_good_ruleset good_imp_wf_ruleset)
      apply(simp add: not_FinalAllow)
      done

  private lemma setbydecision_all_append_subset: "simple_ruleset (rs1 @ rs2)  
            setbydecision_all TYPE('pkt_ext) iface rs1 FinalDeny  {ip. p :: ('i::len,'pkt_ext) tagged_packet_scheme.
            approximating_bigstep_fun (common_matcher, in_doubt_allow) (pp_iiface:=iface_sel iface, p_src := ip) rs2 Undecided = Decision FinalDeny 
            approximating_bigstep_fun (common_matcher, in_doubt_allow) (pp_iiface:=iface_sel iface, p_src := ip) rs1 Undecided = Undecided}
            
            setbydecision_all TYPE('pkt_ext) iface (rs1 @ rs2) FinalDeny"
      unfolding setbydecision_all_def
      apply(subst Set.Collect_disj_eq[symmetric])
      apply(rule Set.Collect_mono)
      apply(subst approximating_bigstep_fun_seq_Undecided_t_wf)
       apply(simp add: simple_imp_good_ruleset good_imp_wf_ruleset)
      apply(simp add: not_FinalAllow)
      done

  private lemma "setbydecision_all TYPE('pkt_ext) iface rs1 FinalDeny 
                 {ip. p :: ('i::len,'pkt_ext) tagged_packet_scheme.
                 approximating_bigstep_fun (common_matcher, in_doubt_allow) (pp_iiface := iface_sel iface, p_src := ip) rs1 Undecided = Undecided}
                 
                 - setbydecision TYPE('pkt_ext) iface rs1 FinalAllow"
      unfolding setbydecision_all_def
      unfolding setbydecision_def
      apply(subst Set.Collect_neg_eq[symmetric])
      apply(subst Set.Collect_disj_eq[symmetric])
      apply(rule Set.Collect_mono)
      by(simp)


  private lemma Collect_minus_eq: "{x. P x} - {x. Q x} = {x. P x  ¬ Q x}" by blast
  private lemma setbydecision_all_append_subset2:
      "simple_ruleset (rs1 @ rs2)  
       setbydecision_all TYPE('pkt_ext) iface rs1 FinalDeny  
      (setbydecision_all TYPE('pkt_ext) iface rs2 FinalDeny - 
       setbydecision TYPE('pkt_ext) iface rs1 FinalAllow)
      setbydecision_all TYPE('pkt_ext) iface (rs1 @ rs2) FinalDeny"
      unfolding setbydecision_all_def
      unfolding setbydecision_def
      apply(subst Collect_minus_eq)
      apply(subst Set.Collect_disj_eq[symmetric])
      apply(rule Set.Collect_mono)
      apply(subst approximating_bigstep_fun_seq_Undecided_t_wf)
       apply(simp add: simple_imp_good_ruleset good_imp_wf_ruleset; fail)
      apply(intro impI allI)
      apply(simp add: not_FinalAllow)
      apply(case_tac "approximating_bigstep_fun (common_matcher, in_doubt_allow) (pp_iiface := iface_sel iface, p_src := x) rs1 Undecided")
       subgoal by(elim disjE) simp_all
      apply(rename_tac x2)
      apply(case_tac x2)
       prefer 2
       apply simp
      apply(elim disjE)
       apply(simp)
      by blast

  private lemma "setbydecision_all TYPE('pkt_ext) iface rs FinalDeny  - setbydecision TYPE('pkt_ext) iface rs FinalAllow"
      apply(simp add: setbydecision_def setbydecision_all_def)
      apply(subst Set.Collect_neg_eq[symmetric])
      apply(rule Set.Collect_mono)
      apply(simp)
      done

  private lemma no_spoofing_algorithm_sound_generalized:
  fixes rs1 :: "'i::len common_primitive rule list"
  shows "simple_ruleset rs1  simple_ruleset rs2 
        (r  set rs2. normalized_nnf_match (get_match r)) 
        setbydecision TYPE('pkt_ext) iface rs1 FinalAllow  allowed 
        denied1  setbydecision_all TYPE('pkt_ext) iface rs1 FinalDeny 
        no_spoofing_algorithm iface ipassmt rs2 allowed denied1 
        nospoof TYPE('pkt_ext) iface ipassmt (rs1@rs2)"
  proof(induction iface ipassmt rs2 allowed denied1 arbitrary: rs1 allowed denied1 rule: no_spoofing_algorithm.induct)
  case (1 iface ipassmt)
    from 1 have "allowed - denied1  ipcidr_union_set (set (the (ipassmt iface)))"
      by(simp)
    with 1 have "setbydecision TYPE('pkt_ext) iface rs1 FinalAllow - setbydecision_all TYPE('pkt_ext) iface rs1 FinalDeny
           ipcidr_union_set (set (the (ipassmt iface)))"
      by blast
    thus ?case 
      by(simp add: nospoof_setbydecision setbydecision_setbydecision_all_Allow)
  next
  case (2 iface ipassmt m rs)
    from 2(2) have simple_rs1: "simple_ruleset rs1" by(simp add: simple_ruleset_def)
    hence simple_rs': "simple_ruleset (rs1 @ [Rule m Accept])" by(simp add: simple_ruleset_def)
    from 2(3) have simple_rs: "simple_ruleset rs" by(simp add: simple_ruleset_def)
    with 2 have IH: "rs' allowed denied1.
      simple_ruleset rs' 
      setbydecision TYPE('pkt_ext) iface rs' FinalAllow  allowed 
      denied1  setbydecision_all TYPE('pkt_ext) iface rs' FinalDeny  
      no_spoofing_algorithm iface ipassmt rs allowed denied1  nospoof TYPE('pkt_ext) iface ipassmt (rs' @ rs)"
      by(simp)
    from 2(5) have "setbydecision TYPE('pkt_ext) iface (rs1 @ [Rule m Accept]) FinalAllow  
      (allowed  {ip. p :: ('i::len,'pkt_ext) tagged_packet_scheme. matches (common_matcher, in_doubt_allow) m Accept (pp_iiface := iface_sel iface, p_src := ip)})"
      apply(simp add: setbydecision_append[OF simple_rs'])
      by blast
    with get_exists_matching_src_ips_subset 2(4) have allowed: "setbydecision TYPE('pkt_ext) iface (rs1 @ [Rule m Accept]) FinalAllow  (allowed  get_exists_matching_src_ips iface m)"
      by fastforce
      
    from 2(6) setbydecision_all_appendAccept[OF simple_rs', where 'pkt_ext = 'pkt_ext] have denied1:
      "denied1  setbydecision_all TYPE('pkt_ext) iface (rs1 @ [Rule m Accept]) FinalDeny" by simp

    from 2(7) have no_spoofing_algorithm_prems: "no_spoofing_algorithm iface ipassmt rs
         (allowed  get_exists_matching_src_ips iface m) denied1"
      by(simp)

    from IH[OF simple_rs' allowed denied1 no_spoofing_algorithm_prems] have "nospoof TYPE('pkt_ext) iface ipassmt ((rs1 @ [Rule m Accept]) @ rs)" by blast
    thus ?case by(simp)
  next
  case (3 iface ipassmt m rs)
    from 3(2) have simple_rs1: "simple_ruleset rs1" by(simp add: simple_ruleset_def)
    hence simple_rs': "simple_ruleset (rs1 @ [Rule m Drop])" by(simp add: simple_ruleset_def)
    from 3(3) have simple_rs: "simple_ruleset rs" by(simp add: simple_ruleset_def)
    with 3 have IH: "rs' allowed denied1.
      simple_ruleset rs' 
      setbydecision TYPE('pkt_ext) iface rs' FinalAllow  allowed 
      denied1  setbydecision_all TYPE('pkt_ext) iface rs' FinalDeny  
      no_spoofing_algorithm iface ipassmt rs allowed denied1  nospoof TYPE('pkt_ext) iface ipassmt (rs' @ rs)"
      by(simp)
    from 3(5) simple_rs' have allowed: "setbydecision TYPE('pkt_ext) iface (rs1 @ [Rule m Drop]) FinalAllow  allowed "
      by(simp add: setbydecision_append)
    
    have "{ip. p :: ('i,'pkt_ext) tagged_packet_scheme. matches (common_matcher, in_doubt_allow) m Drop (pp_iiface := iface_sel iface, p_src := ip)}  
          setbydecision_all TYPE('pkt_ext) iface [Rule m Drop] FinalDeny" by(simp add: setbydecision_all_def)
    with 3(5) have "setbydecision_all TYPE('pkt_ext) iface rs1 FinalDeny  ({ip. p :: ('i,'pkt_ext) tagged_packet_scheme. matches (common_matcher, in_doubt_allow) m Drop (pp_iiface := iface_sel iface, p_src := ip)} - allowed) 
          setbydecision_all TYPE('pkt_ext) iface rs1 FinalDeny  (setbydecision_all TYPE('pkt_ext) iface [Rule m Drop] FinalDeny - setbydecision TYPE('pkt_ext) iface rs1 FinalAllow)"
      by blast
    with 3(6) setbydecision_all_append_subset2[OF simple_rs', of iface] have
     "denied1  ({ip. p :: ('i,'pkt_ext) tagged_packet_scheme. matches (common_matcher, in_doubt_allow) m Drop (pp_iiface := iface_sel iface, p_src := ip)} - allowed) 
      setbydecision_all TYPE('pkt_ext) iface (rs1 @ [Rule m Drop]) FinalDeny"
      by blast
    with get_all_matching_src_ips 3(4) have denied1:
     "denied1  (get_all_matching_src_ips iface m - allowed)  setbydecision_all TYPE('pkt_ext) iface (rs1 @ [Rule m Drop]) FinalDeny"
      by force

    from 3(7) have no_spoofing_algorithm_prems: "no_spoofing_algorithm iface ipassmt rs allowed
     (denied1  (get_all_matching_src_ips iface m - allowed))"
      apply(simp)
      done

    from IH[OF simple_rs' allowed denied1 no_spoofing_algorithm_prems] have "nospoof TYPE('pkt_ext) iface ipassmt ((rs1 @ [Rule m Drop]) @ rs)" by blast
    thus ?case by(simp)
  next
  case "4_1" thus ?case by(simp add: simple_ruleset_def)
  next
  case "4_2" thus ?case by(simp add: simple_ruleset_def)
  next
  case "4_3" thus ?case by(simp add: simple_ruleset_def)
  next
  case "4_4" thus ?case by(simp add: simple_ruleset_def)
  next
  case "4_5" thus ?case by(simp add: simple_ruleset_def)
  next
  case "4_6" thus ?case by(simp add: simple_ruleset_def)
  next
  case "4_7" thus ?case by(simp add: simple_ruleset_def)
  qed

  definition no_spoofing_iface :: "iface  'i::len ipassignment  'i common_primitive rule list  bool" where
    "no_spoofing_iface iface ipassmt rs  no_spoofing_algorithm iface ipassmt rs {} {}"

  lemma[code]: "no_spoofing_iface iface ipassmt rs = 
      no_spoofing_algorithm_executable iface ipassmt rs Empty_WordInterval Empty_WordInterval"
    by(simp add: no_spoofing_iface_def no_spoofing_algorithm_executable)

  private corollary no_spoofing_algorithm_sound: "simple_ruleset rs  rset rs. normalized_nnf_match (get_match r) 
        no_spoofing_iface iface ipassmt rs   nospoof TYPE('pkt_ext) iface ipassmt rs"
    unfolding no_spoofing_iface_def
    apply(rule no_spoofing_algorithm_sound_generalized[of "[]" rs iface "{}" "{}", simplified])
        apply(simp_all)
     apply(simp add: simple_ruleset_def)
    apply(simp add: setbydecision_def)
    done
    

  text‹The @{const nospoof} definition used throughout the proofs corresponds to checking @{const no_spoofing} for all interfaces›
  private lemma nospoof: "simple_ruleset rs  (iface  dom ipassmt. nospoof TYPE('pkt_ext) iface ipassmt rs)  no_spoofing TYPE('pkt_ext) ipassmt rs"
    unfolding nospoof_def no_spoofing_def
    apply(drule simple_imp_good_ruleset)
    apply(subst approximating_semantics_iff_fun_good_ruleset)
    apply(simp_all)
    done


  theorem no_spoofing_iface: "simple_ruleset rs  rset rs. normalized_nnf_match (get_match r) 
        iface  dom ipassmt. no_spoofing_iface iface ipassmt rs   no_spoofing TYPE('pkt_ext) ipassmt rs"
    by(auto dest: nospoof no_spoofing_algorithm_sound)
  


text‹Examples›
  text‹Example 1:
    Ruleset: Accept all non-spoofed packets, drop rest.
  ›
  lemma "no_spoofing_iface
      (Iface ''eth0'') 
          [Iface ''eth0''  [(ipv4addr_of_dotdecimal (192,168,0,0), 24)]]
          [Rule (MatchAnd (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (192,168,0,0)) 24))) (Match (IIface (Iface ''eth0'')))) action.Accept,
           Rule MatchAny action.Drop]" by eval
  lemma "no_spoofing TYPE('pkt_ext)
          [Iface ''eth0''  [(ipv4addr_of_dotdecimal (192,168,0,0), 24)]]
          [Rule (MatchAnd (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (192,168,0,0)) 24))) (Match (IIface (Iface ''eth0'')))) action.Accept,
           Rule MatchAny action.Drop]"
    apply(rule no_spoofing_iface)
      apply(simp_all add: simple_ruleset_def) (*simple and nnf*)
    by eval (*executable spoofing alogorithm*)


  text‹Example 2:
    Ruleset: Drop packets from a spoofed IP range, allow rest.
    Handles negated interfaces correctly.
  ›
  lemma "no_spoofing TYPE('pkt_ext)
      [Iface ''eth0''  [(ipv4addr_of_dotdecimal (192,168,0,0), 24)]]
      [Rule (MatchAnd (Match (IIface (Iface ''wlan+''))) (Match (Extra ''no idea what this is''))) action.Accept, ― ‹not interesting for spoofing›
       Rule (MatchNot (Match (IIface (Iface ''eth0+'')))) action.Accept, ― ‹not interesting for spoofing›
       Rule (MatchAnd (MatchNot (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (192,168,0,0)) 24)))) (Match (IIface (Iface ''eth0'')))) action.Drop, ― ‹spoof-protect here›
       Rule MatchAny action.Accept]
          "
    apply(rule no_spoofing_iface)
      apply(simp_all add: simple_ruleset_def)
    by eval
   
    
  text‹Example 3:
    Accidentally, matching on wlan+, spoofed packets for eth0 are allowed.
    First, we prove that there actually is no spoofing protection. Then we show that our algorithm finds out.
›
  lemma "¬ no_spoofing TYPE('pkt_ext)
          [Iface ''eth0''  [(ipv4addr_of_dotdecimal (192,168,0,0), 24)]]
          [Rule (MatchNot (Match (IIface (Iface ''wlan+'')))) action.Accept, ― ‹accidently allow everything for eth0›
           Rule (MatchAnd (MatchNot (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (192,168,0,0)) 24)))) (Match (IIface (Iface ''eth0'')))) action.Drop,
           Rule MatchAny action.Accept]
          "
     apply(simp add: no_spoofing_def)
     apply(rule_tac x="pp_src := 0" in exI) (*any p*)
     apply(simp add: range_0_max_UNIV ipcidr_union_set_def)
      apply(intro conjI)
      apply(subst approximating_semantics_iff_fun_good_ruleset)
       apply(simp add: good_ruleset_def; fail)
      apply(simp add: bunch_of_lemmata_about_matches
          match_simplematcher_SrcDst_not
          primitive_matcher_generic.Iface_single[OF primitive_matcher_generic_common_matcher]
          primitive_matcher_generic.Iface_single_not[OF primitive_matcher_generic_common_matcher])
      apply(intro impI, thin_tac _)
      apply eval
     apply eval
     done

   lemma "¬ no_spoofing_iface 
          (Iface ''eth0'') 
          [Iface ''eth0''  [(ipv4addr_of_dotdecimal (192,168,0,0), 24)]]
          [Rule (MatchNot (Match (IIface (Iface ''wlan+'')))) action.Accept, ― ‹accidently allow everything for eth0›
           Rule (MatchAnd (MatchNot (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (192,168,0,0)) 24)))) (Match (IIface (Iface ''eth0'')))) action.Drop,
           Rule MatchAny action.Accept]
          " by eval

  text‹Example 4:
    Ruleset: Drop packets coming from the wrong interface, allow the rest.
    Warning: this does not prevent spoofing for eth0!
    Explanation: someone on eth0 can send a packet e.g. with source IP 8.8.8.8
    The ruleset only prevents spoofing of 192.168.0.0/24 for other interfaces
›
   lemma "¬ no_spoofing TYPE('pkt_ext) [Iface ''eth0''  [(ipv4addr_of_dotdecimal (192,168,0,0), 24)]]
          [Rule (MatchAnd (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (192,168,0,0)) 24))) (MatchNot (Match (IIface (Iface ''eth0''))))) action.Drop,
           Rule MatchAny action.Accept]"
     apply(simp add: no_spoofing_def)
     apply(rule_tac x="pp_src := 0" in exI) (*any p*)
     apply(simp add: range_0_max_UNIV ipcidr_union_set_def)
      apply(intro conjI)
      apply(subst approximating_semantics_iff_fun_good_ruleset)
       apply(simp add: good_ruleset_def; fail)
      apply(simp add: bunch_of_lemmata_about_matches
          primitive_matcher_generic.Iface_single[OF primitive_matcher_generic_common_matcher]
          primitive_matcher_generic.Iface_single_not[OF primitive_matcher_generic_common_matcher])
      apply(intro impI, thin_tac _)
      apply eval
     apply eval
     done
  
  text‹Our algorithm detects it.›
  lemma "¬ no_spoofing_iface 
          (Iface ''eth0'') 
          [Iface ''eth0''  [(ipv4addr_of_dotdecimal (192,168,0,0), 24)]]
          [Rule (MatchAnd (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (192,168,0,0)) 24))) (MatchNot (Match (IIface (Iface ''eth0''))))) action.Drop,
           Rule MatchAny action.Accept]" by eval

  text‹Example 5:
    Spoofing protection but the algorithm fails.
    The algorithm @{const no_spoofing_iface} is only sound, not complete.
    The ruleset first drops spoofed packets for TCP and then drops spoofed packets for ¬ TCP›.
    The algorithm cannot detect that TCP ∪ ¬TCP› together will match all spoofed packets.›

  lemma "no_spoofing TYPE('pkt_ext) [Iface ''eth0''  [(ipv4addr_of_dotdecimal (192,168,0,0), 24)]]
          [Rule (MatchAnd (MatchNot (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (192,168,0,0)) 24))))
                (MatchAnd (Match (IIface (Iface ''eth0'')))
                          (Match (Prot (Proto TCP))))) action.Drop,
           Rule (MatchAnd (MatchNot (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (192,168,0,0)) 24))))
                (MatchAnd (Match (IIface (Iface ''eth0'')))
                          (MatchNot (Match (Prot (Proto TCP)))))) action.Drop,
           Rule MatchAny action.Accept]" (is "no_spoofing TYPE('pkt_ext) ?ipassmt ?rs")
  proof -
    have 1: "p. (common_matcher, in_doubt_allow),p ?rs, Undecided α Decision FinalAllow 
                 approximating_bigstep_fun (common_matcher, in_doubt_allow) p ?rs Undecided = Decision FinalAllow"
      by(subst approximating_semantics_iff_fun_good_ruleset) (simp_all add: good_ruleset_def)
    show ?thesis
      unfolding no_spoofing_def
      apply(simp add: 1 ipcidr_union_set_def)
      apply(simp add: bunch_of_lemmata_about_matches
          primitive_matcher_generic.Iface_single[OF primitive_matcher_generic_common_matcher]
          primitive_matcher_generic.Iface_single_not[OF primitive_matcher_generic_common_matcher])
      apply(simp add: match_iface.simps match_simplematcher_SrcDst_not
                      primitive_matcher_generic.Prot_single[OF primitive_matcher_generic_common_matcher]
                      primitive_matcher_generic.Prot_single_not[OF primitive_matcher_generic_common_matcher])
      done
  qed
  text‹Spoofing protection but the algorithm cannot certify spoofing protection.›
  lemma "¬ no_spoofing_iface
          (Iface ''eth0'') 
          [Iface ''eth0''  [(ipv4addr_of_dotdecimal (192,168,0,0), 24)]]
          [Rule (MatchAnd (MatchNot (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (192,168,0,0)) 24))))
                (MatchAnd (Match (IIface (Iface ''eth0'')))
                (Match (Prot (Proto TCP))))) action.Drop,
           Rule (MatchAnd (MatchNot (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (192,168,0,0)) 24))))
                (MatchAnd (Match (IIface (Iface ''eth0'')))
                (MatchNot (Match (Prot (Proto TCP)))))) action.Drop,
           Rule MatchAny action.Accept]" by eval

end

lemma "no_spoofing_iface (Iface ''eth1.1011'')
                         ([Iface ''eth1.1011''  [(ipv4addr_of_dotdecimal (131,159,14,0), 24)]]:: 32 ipassignment)
  [Rule (MatchNot (Match (IIface (Iface ''eth1.1011+'')))) action.Accept,
   Rule (MatchAnd (MatchNot (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (131,159,14,0)) 24)))) (Match (IIface (Iface ''eth1.1011'')))) action.Drop,
   Rule MatchAny action.Accept]" by eval

text‹We only check accepted packets.
      If there is no default rule (this will never happen if parsed from iptables!), the result is unfinished.›
lemma "no_spoofing_iface (Iface ''eth1.1011'')
                         ([Iface ''eth1.1011''  [(ipv4addr_of_dotdecimal (131,159,14,0), 24)]]:: 32 ipassignment)
  [Rule (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (127, 0, 0, 0)) 8))) Drop]" by eval

end

Theory Common_Primitive_toString

theory Common_Primitive_toString
imports Simple_Firewall.Primitives_toString
        Common_Primitive_Matcher
begin


section‹Firewall toString Functions›

fun ipt_ipv4range_toString :: "32 ipt_iprange  string" where
  "ipt_ipv4range_toString (IpAddr ip) = ipv4addr_toString ip" |
  "ipt_ipv4range_toString (IpAddrNetmask ip n) = ipv4addr_toString ip@''/''@string_of_nat n"  |
  "ipt_ipv4range_toString (IpAddrRange ip1 ip2) = ipv4addr_toString ip1@''-''@ipv4addr_toString ip2"

fun ipt_ipv6range_toString :: "128 ipt_iprange  string" where
  "ipt_ipv6range_toString (IpAddr ip) = ipv6addr_toString ip" |
  "ipt_ipv6range_toString (IpAddrNetmask ip n) = ipv6addr_toString ip@''/''@string_of_nat n"  |
  "ipt_ipv6range_toString (IpAddrRange ip1 ip2) = ipv6addr_toString ip1@''-''@ipv6addr_toString ip2"

definition ipv4addr_wordinterval_pretty_toString :: "32 wordinterval  string" where
  "ipv4addr_wordinterval_pretty_toString wi = list_toString ipt_ipv4range_toString (wi_to_ipt_iprange wi)"

lemma "ipv4addr_wordinterval_pretty_toString 
    (RangeUnion (RangeUnion (WordInterval 0x7F000000 0x7FFFFFFF) (WordInterval 0x1020304 0x1020306))
                (WordInterval 0x8080808 0x8080808)) = ''[127.0.0.0/8, 1.2.3.4-1.2.3.6, 8.8.8.8]''" by eval
  


fun action_toString :: "action  string" where
  "action_toString action.Accept = ''-j ACCEPT''" |
  "action_toString action.Drop = ''-j DROP''" |
  "action_toString action.Reject = ''-j REJECT''" |
  "action_toString (action.Call target) = ''-j ''@target@'' (call)''" |
  "action_toString (action.Goto target) = ''-g ''@target" |
  "action_toString action.Empty = ''''" |
  "action_toString action.Log = ''-j LOG''" |
  "action_toString action.Return = ''-j RETURN''" |
  "action_toString action.Unknown = ''!!!!!!!!!!! UNKNOWN !!!!!!!!!!!''"


fun common_primitive_toString :: "('i::len word  string)  'i common_primitive  string" where
  "common_primitive_toString ipToStr (Src (IpAddr ip)) = ''-s ''@ipToStr ip" |
  "common_primitive_toString ipToStr (Dst (IpAddr ip)) = ''-d ''@ipToStr ip" |
  "common_primitive_toString ipToStr (Src (IpAddrNetmask ip n)) = ''-s ''@ipToStr ip@''/''@string_of_nat n"  |
  "common_primitive_toString ipToStr (Dst (IpAddrNetmask ip n)) = ''-d ''@ipToStr ip@''/''@string_of_nat n"  |
  "common_primitive_toString ipToStr (Src (IpAddrRange ip1 ip2)) = ''-m iprange --src-range ''@ipToStr ip1@''-''@ipToStr ip2"  |
  "common_primitive_toString ipToStr (Dst (IpAddrRange ip1 ip2)) = ''-m iprange --dst-range ''@ipToStr ip1@''-''@ipToStr ip2"  |
  "common_primitive_toString _ (IIface ifce) = iface_toString ''-i '' ifce" |
  "common_primitive_toString _ (OIface ifce) = iface_toString ''-o '' ifce" |
  "common_primitive_toString _ (Prot prot) = ''-p ''@protocol_toString prot" |
  "common_primitive_toString _ (Src_Ports (L4Ports prot pts)) = ''-m ''@primitive_protocol_toString prot@'' --spts '' @ list_toString (ports_toString '''') pts" |
  "common_primitive_toString _ (Dst_Ports (L4Ports prot pts)) = ''-m ''@primitive_protocol_toString prot@'' --dpts '' @ list_toString (ports_toString '''') pts" |
  "common_primitive_toString _ (MultiportPorts (L4Ports prot pts)) = ''-p ''@primitive_protocol_toString prot@'' -m multiport --ports '' @ list_toString (ports_toString '''') pts" |
  "common_primitive_toString _ (CT_State S) = ''-m state --state ''@ctstate_set_toString S" |
  "common_primitive_toString _ (L4_Flags (TCP_Flags c m)) = ''--tcp-flags ''@ipt_tcp_flags_toString c@'' ''@ipt_tcp_flags_toString m" |
  "common_primitive_toString _ (Extra e) = ''~~''@e@''~~''"


definition common_primitive_ipv4_toString :: "32 common_primitive  string" where
  "common_primitive_ipv4_toString  common_primitive_toString ipv4addr_toString"

definition common_primitive_ipv6_toString :: "128 common_primitive  string" where
  "common_primitive_ipv6_toString  common_primitive_toString ipv6addr_toString"


fun common_primitive_match_expr_toString
  :: "('i common_primitive  string)  'i common_primitive match_expr  string" where
  "common_primitive_match_expr_toString toStr MatchAny = ''''" |
  "common_primitive_match_expr_toString toStr (Match m) = toStr m" |
  "common_primitive_match_expr_toString toStr (MatchAnd m1 m2) =
      common_primitive_match_expr_toString toStr m1 @'' '' @ common_primitive_match_expr_toString toStr m2" |
  "common_primitive_match_expr_toString toStr (MatchNot (Match m)) = ''! ''@toStr m" |
  "common_primitive_match_expr_toString toStr (MatchNot m) = ''NOT (''@common_primitive_match_expr_toString toStr m@'')''"

definition common_primitive_match_expr_ipv4_toString :: "32 common_primitive match_expr  string" where
  "common_primitive_match_expr_ipv4_toString  common_primitive_match_expr_toString common_primitive_ipv4_toString"

definition common_primitive_match_expr_ipv6_toString :: "128 common_primitive match_expr  string" where
  "common_primitive_match_expr_ipv6_toString  common_primitive_match_expr_toString common_primitive_ipv6_toString"

fun common_primitive_rule_toString :: "32 common_primitive rule  string" where
  "common_primitive_rule_toString (Rule m a) = common_primitive_match_expr_ipv4_toString m @'' ''@action_toString a"


end

Theory Routing_IpAssmt

section‹Routing and IP Assignments›
theory Routing_IpAssmt
imports Ipassmt
        Routing.Routing_Table
begin
context
begin

subsection‹Routing IP Assignment›
text‹Up to now, the definitions were all still on word intervals because those are much more convenient to work with.›

definition routing_ipassmt :: "'i::len routing_rule list  (iface × ('i word × nat) list) list"
  where
  "routing_ipassmt rt  map (apfst Iface  apsnd cidr_split) (routing_ipassmt_wi rt)"

private lemma ipcidr_union_cidr_split[simp]: "ipcidr_union_set (set (cidr_split x)) = wordinterval_to_set x" 
  apply(subst cidr_split_prefix[symmetric])
  apply(fact ipcidr_union_set_uncurry)
done

private lemma map_of_map_Iface: "map_of (map (λx. (Iface (fst x), f (snd x))) xs) (Iface ifce) = 
        map_option f ((map_of xs) ifce)"
  by (induct xs) (auto)

lemma "routing_ipassmt_wi ([]::32 prefix_routing) = [(output_iface (routing_action (undefined :: 32 routing_rule)), WordInterval 0 0xFFFFFFFF)]"
  by code_simp


lemma routing_ipassmt: "
    valid_prefixes rt 
    output_iface (routing_table_semantics rt (p_dst p)) = p_oiface p 
    p_ips. map_of (routing_ipassmt rt) (Iface (p_oiface p)) = Some p_ips  p_dst p  ipcidr_union_set (set p_ips)"
  apply(simp add: routing_ipassmt_def)
  apply(drule routing_ipassmt_wi[where output_port="p_oiface p" and k="p_dst p"])
  apply(simp)
  apply(elim exE, rename_tac ip_range)
  apply(rule_tac x="cidr_split ip_range" in exI)
  apply(simp)
  apply(simp add: comp_def)
  apply(simp add: map_of_map_Iface)
  apply(rule_tac x="ip_range" in exI)
  apply(simp)
  by (simp add: routing_ipassmt_wi_distinct)

lemma routing_ipassmt_ipassmt_sanity_disjoint: "valid_prefixes (rt::('i::len) prefix_routing) 
    ipassmt_sanity_disjoint (map_of (routing_ipassmt rt))"
unfolding ipassmt_sanity_disjoint_def routing_ipassmt_def comp_def
  apply(clarsimp)
  apply(drule map_of_SomeD)+
  apply(clarsimp split: iface.splits)
using routing_ipassmt_wi_disjoint[where 'i = 'i] by meson

lemma routing_ipassmt_distinct: "distinct (map fst (routing_ipassmt rtbl))"
  using routing_ipassmt_wi_distinct[of rtbl]
  unfolding routing_ipassmt_def
  apply(simp add: comp_def)
  apply(subst distinct_map[where f = Iface and xs = "map fst (routing_ipassmt_wi rtbl)", simplified, unfolded comp_def])
  apply(auto intro: inj_onI)
done
  
end

end

Theory Output_Interface_Replace

theory Output_Interface_Replace
imports
  Ipassmt
  Routing_IpAssmt
  Common_Primitive_toString
begin

section‹Replacing output interfaces by their IP ranges according to Routing›

text‹Copy of @{file ‹Interface_Replace.thy›}

definition ipassmt_iface_replace_dstip_mexpr
  :: "'i::len ipassignment  iface  'i common_primitive match_expr" where
  "ipassmt_iface_replace_dstip_mexpr ipassmt ifce  case ipassmt ifce of
          None  Match (OIface ifce)
        | Some ips  (match_list_to_match_expr (map (Match  Dst) (map (uncurry IpAddrNetmask) ips)))"

lemma matches_ipassmt_iface_replace_dstip_mexpr: 
    "matches (common_matcher, α) (ipassmt_iface_replace_dstip_mexpr ipassmt ifce) a p  (case ipassmt ifce of
            None  match_iface ifce (p_oiface p)
          | Some ips  p_dst p  ipcidr_union_set (set ips)
          )"
proof(cases "ipassmt ifce")
case None thus ?thesis by(simp add: ipassmt_iface_replace_dstip_mexpr_def primitive_matcher_generic.Iface_single[OF primitive_matcher_generic_common_matcher])
next
case (Some ips)
  have "matches (common_matcher, α) (match_list_to_match_expr (map (Match  Dst  (uncurry IpAddrNetmask)) ips)) a p 
       (mset ips. p_dst p  (uncurry ipset_from_cidr m))" 
       by(simp add: match_list_to_match_expr_disjunction[symmetric]
                    match_list_matches match_simplematcher_SrcDst ipt_iprange_to_set_uncurry_IpAddrNetmask)
  with Some show ?thesis
    by(simp add: ipassmt_iface_replace_dstip_mexpr_def bunch_of_lemmata_about_matches ipcidr_union_set_uncurry)
qed


fun oiface_rewrite
  :: "'i::len ipassignment  'i common_primitive match_expr  'i common_primitive match_expr"
where
  "oiface_rewrite _       MatchAny = MatchAny" |
  "oiface_rewrite ipassmt (Match (OIface ifce)) = ipassmt_iface_replace_dstip_mexpr ipassmt ifce" |
  "oiface_rewrite _       (Match a) = Match a" |
  "oiface_rewrite ipassmt (MatchNot m) = MatchNot (oiface_rewrite ipassmt m)" |
  "oiface_rewrite ipassmt (MatchAnd m1 m2) = MatchAnd (oiface_rewrite ipassmt m1) (oiface_rewrite ipassmt m2)"


context
begin
  (*helper1: used in induction case MatchNot*)
  private lemma oiface_rewrite_matches_Primitive:
          "matches (common_matcher, α) (MatchNot (oiface_rewrite ipassmt (Match x))) a p = matches (common_matcher, α) (MatchNot (Match x)) a p 
           matches (common_matcher, α) (oiface_rewrite ipassmt (Match x)) a p = matches (common_matcher, α) (Match x) a p"
  proof(cases x)
  case (OIface ifce)
    have "(matches (common_matcher, α) (MatchNot (ipassmt_iface_replace_dstip_mexpr ipassmt ifce)) a p = (¬ match_iface ifce (p_oiface p))) 
      (matches (common_matcher, α) (ipassmt_iface_replace_dstip_mexpr ipassmt ifce) a p = match_iface ifce (p_oiface p))"
    proof(cases "ipassmt ifce")
    case None thus ?thesis
       apply(simp add: matches_ipassmt_iface_replace_dstip_mexpr)
       apply(simp add: ipassmt_iface_replace_dstip_mexpr_def primitive_matcher_generic.Iface_single_not[OF primitive_matcher_generic_common_matcher])
       done
     next
     case (Some ips)
       {  fix ips
          have "matches (common_matcher, α)
                 (MatchNot (match_list_to_match_expr (map (Match  Dst  (uncurry IpAddrNetmask)) ips))) a p 
                 (p_dst p  ipcidr_union_set (set ips))"
        apply(induction ips)
         apply(simp add: bunch_of_lemmata_about_matches ipcidr_union_set_uncurry)
        apply(simp add: MatchOr_MatchNot)
        apply(simp add: ipcidr_union_set_uncurry)
        apply(simp add: match_simplematcher_SrcDst_not)
        apply(thin_tac _)
        apply(simp add: ipt_iprange_to_set_uncurry_IpAddrNetmask)
        done
       } note helper=this
       from Some show ?thesis
         apply(simp add: matches_ipassmt_iface_replace_dstip_mexpr)
         apply(simp add: ipassmt_iface_replace_dstip_mexpr_def)
         apply(simp add: helper)
         done
     qed
     with OIface show ?thesis
      by(simp add: primitive_matcher_generic.Iface_single_not[OF primitive_matcher_generic_common_matcher]
            primitive_matcher_generic.Iface_single[OF primitive_matcher_generic_common_matcher])
  qed(simp_all)

  lemma ipassmt_disjoint_matcheq_iifce_dstip:
        assumes ipassmt_nowild: "ipassmt_sanity_nowildcards ipassmt"
            and ipassmt_disjoint: "ipassmt_sanity_disjoint ipassmt"
            and ifce: "ipassmt ifce = Some i_ips"
            and p_ifce: "ipassmt (Iface (p_oiface p)) = Some p_ips  p_dst p  ipcidr_union_set (set p_ips)"
        shows   "match_iface ifce (p_oiface p)  p_dst p  ipcidr_union_set (set i_ips)"
    proof
     assume "match_iface ifce (p_oiface p)"
     thus "p_dst p  ipcidr_union_set (set i_ips)"
       apply(cases "ifce = Iface (p_oiface p)")
        using ifce p_ifce apply force
       by (metis domI iface.sel iface_is_wildcard_def ifce ipassmt_nowild ipassmt_sanity_nowildcards_def match_iface.elims(2) match_iface_case_nowildcard)
   next
     assume a: "p_dst p  ipcidr_union_set (set i_ips)"
     ― ‹basically, we need to reverse the map @{term ipassmt}

     from ipassmt_disjoint_nonempty_inj[OF ipassmt_disjoint ifce] a have ipassmt_inj: "k. ipassmt k = Some i_ips  k = ifce" by blast

     from ipassmt_disjoint_inj_k[OF ipassmt_disjoint ifce _ a] have ipassmt_inj_k:
      "k ips'. ipassmt k = Some ips'  p_dst p  ipcidr_union_set (set ips')  k = ifce" by simp

     have ipassmt_inj_p: "ips'. p_dst p  ipcidr_union_set (set ips')  (k. ipassmt k = Some ips')  ips' = i_ips"
     (*using ipassmt_inj_k ifce by force*)
     proof(intro allI impI; elim conjE exE)
       fix ips' k
       assume as: "p_dst p  ipcidr_union_set (set ips')" "ipassmt k = Some ips'"
       hence "k = ifce" using ipassmt_inj_k by simp
       thus "ips' = i_ips" using ifce as by simp
     qed

     from p_ifce have "(Iface (p_oiface p)) = ifce" using ipassmt_inj_p ipassmt_inj by blast 

     thus "match_iface ifce (p_oiface p)" using match_iface_refl by blast 
   qed


  (*helper2: used in induction base case*)
  private lemma matches_ipassmt_iface_replace_dstip_mexpr_case_Iface:
        fixes ifce::iface
        assumes "ipassmt_sanity_nowildcards ipassmt"
            and "ipassmt_sanity_disjoint ipassmt"
            and "ipassmt (Iface (p_oiface p)) = Some p_ips  p_dst p  ipcidr_union_set (set p_ips)"
        shows   "matches (common_matcher, α) (ipassmt_iface_replace_dstip_mexpr ipassmt ifce) a p 
                 matches (common_matcher, α) (Match (OIface ifce)) a p"
  proof -
    have "matches (common_matcher, α) (ipassmt_iface_replace_dstip_mexpr ipassmt ifce) a p = match_iface ifce (p_oiface p)"
      proof -
        show ?thesis
        proof(cases "ipassmt ifce")
          case None thus ?thesis by(simp add: matches_ipassmt_iface_replace_dstip_mexpr)
          next
          case (Some y) with assms(2) have "p_dst p  ipcidr_union_set (set y) = match_iface ifce (p_oiface p)"
            using assms(1) assms(3) ipassmt_disjoint_matcheq_iifce_dstip by blast
            with Some show ?thesis by(simp add: matches_ipassmt_iface_replace_dstip_mexpr)
        qed
    qed
    thus ?thesis by(simp add: primitive_matcher_generic.Iface_single[OF primitive_matcher_generic_common_matcher])
  qed



  lemma matches_oiface_rewrite_ipassmt:
       "normalized_nnf_match m  ipassmt_sanity_nowildcards ipassmt  ipassmt_sanity_disjoint ipassmt 
        (p_ips. ipassmt (Iface (p_oiface p)) = Some p_ips  p_dst p  ipcidr_union_set (set p_ips)) 
        matches (common_matcher, α) (oiface_rewrite ipassmt m) a p  matches (common_matcher, α) m a p"
    proof(induction m)
    case MatchAny thus ?case by simp
    next
    case (MatchNot m)
      hence IH: "normalized_nnf_match m 
        matches (common_matcher, α) (oiface_rewrite ipassmt m) a p =matches (common_matcher, α) m a p" by blast
      with MatchNot.prems IH show ?case by(induction m) (simp_all add: oiface_rewrite_matches_Primitive)
    next
    case(Match x) thus ?case
      proof(cases x)
        case (OIface ifce) with Match show ?thesis
        apply(cases "ipassmt (Iface (p_oiface p))")
         prefer 2
          apply(simp add: matches_ipassmt_iface_replace_dstip_mexpr_case_Iface; fail)
        by auto
      qed(simp_all)
    next
    case (MatchAnd m1 m2) thus ?case by(simp add: bunch_of_lemmata_about_matches)
    qed

  lemma matches_oiface_rewrite:
       "normalized_nnf_match m  ipassmt_sanity_nowildcards ipassmt ― ‹TODO: check?› 
        correct_routing rt 
        ipassmt = map_of (routing_ipassmt rt) 
        output_iface (routing_table_semantics rt (p_dst p)) = p_oiface p 
        matches (common_matcher, α) (oiface_rewrite ipassmt m) a p  matches (common_matcher, α) m a p"
  apply(rule matches_oiface_rewrite_ipassmt; assumption?)
   apply(simp add: correct_routing_def routing_ipassmt_ipassmt_sanity_disjoint; fail)
  apply(simp)
  apply(rule routing_ipassmt; assumption?)
   apply(simp add: correct_routing_def; fail)
  done
end

lemma oiface_rewrite_preserves_nodisc:
  "a. ¬ disc (Dst a)  ¬ has_disc disc m  ¬ has_disc disc (oiface_rewrite ipassmt m)"
  proof(induction ipassmt m rule: oiface_rewrite.induct)
  case 2 
    have "a. ¬ disc (Dst a)  ¬ disc (OIface ifce)  ¬ has_disc disc (ipassmt_iface_replace_dstip_mexpr ipassmt ifce)"
      for ifce ipassmt
      apply(simp add: ipassmt_iface_replace_dstip_mexpr_def split: option.split)
      apply(intro allI impI, rename_tac ips)
      apply(drule_tac X=Dst and ls="map (uncurry IpAddrNetmask) ips" in match_list_to_match_expr_not_has_disc)
      apply(simp)
      done
    with 2 show ?case by simp
  qed(simp_all)


end

Theory Interface_Replace

theory Interface_Replace
imports
  No_Spoof
  Common_Primitive_toString
  Output_Interface_Replace
begin

section‹Trying to connect inbound interfaces by their IP ranges›
subsection‹Constraining Interfaces›

text‹We keep the match on the interface but add the corresponding IP address range.›

definition ipassmt_iface_constrain_srcip_mexpr
  :: "'i::len ipassignment  iface  'i common_primitive match_expr"
where
  "ipassmt_iface_constrain_srcip_mexpr ipassmt ifce = (case ipassmt ifce of
          None  Match (IIface ifce)
        | Some ips  MatchAnd
            (Match (IIface ifce))
            (match_list_to_match_expr (map (Match  Src) (map (uncurry IpAddrNetmask) ips)))
        )"

lemma matches_ipassmt_iface_constrain_srcip_mexpr: 
    "matches (common_matcher, α) (ipassmt_iface_constrain_srcip_mexpr ipassmt ifce) a p 
      (case ipassmt ifce of
            None  match_iface ifce (p_iiface p)
          | Some ips  match_iface ifce (p_iiface p)  p_src p  ipcidr_union_set (set ips)
          )"
proof(cases "ipassmt ifce")
case None thus ?thesis by(simp add: ipassmt_iface_constrain_srcip_mexpr_def primitive_matcher_generic.Iface_single[OF primitive_matcher_generic_common_matcher]; fail)
next
case (Some ips)
  have "matches (common_matcher, α) (match_list_to_match_expr (map (Match  Src  (uncurry IpAddrNetmask)) ips)) a p 
       (mset ips. p_src p  uncurry ipset_from_cidr m)" 
       apply(simp add: match_list_to_match_expr_disjunction[symmetric]
                       match_list_matches match_simplematcher_SrcDst)
       by(simp add: ipt_iprange_to_set_uncurry_IpAddrNetmask)
  with Some show ?thesis
    apply(simp add: ipcidr_union_set_uncurry)
    apply(simp add: ipassmt_iface_constrain_srcip_mexpr_def bunch_of_lemmata_about_matches)
    apply(simp add: primitive_matcher_generic.Iface_single[OF primitive_matcher_generic_common_matcher])
    done
qed


fun iiface_constrain :: "'i::len ipassignment  'i common_primitive match_expr  'i common_primitive match_expr" where
  "iiface_constrain _       MatchAny = MatchAny" |
  "iiface_constrain ipassmt (Match (IIface ifce)) = ipassmt_iface_constrain_srcip_mexpr ipassmt ifce" |
  "iiface_constrain ipassmt (Match a) = Match a" |
  "iiface_constrain ipassmt (MatchNot m) = MatchNot (iiface_constrain ipassmt m)" |
  "iiface_constrain ipassmt (MatchAnd m1 m2) = MatchAnd (iiface_constrain ipassmt m1) (iiface_constrain ipassmt m2)"


context
begin
  (*helper1: used in induction case MatchNot*)
  private lemma iiface_constrain_matches_Primitive:
          "matches (common_matcher, α) (MatchNot (iiface_constrain ipassmt (Match x))) a p = matches (common_matcher, α) (MatchNot (Match x)) a p 
           matches (common_matcher, α) (iiface_constrain ipassmt (Match x)) a p = matches (common_matcher, α) (Match x) a p"
  proof(cases x)
  case (IIface ifce)
    have "(matches (common_matcher, α) (MatchNot (ipassmt_iface_constrain_srcip_mexpr ipassmt ifce)) a p = (¬ match_iface ifce (p_iiface p))) 
      (matches (common_matcher, α) (ipassmt_iface_constrain_srcip_mexpr ipassmt ifce) a p = match_iface ifce (p_iiface p))"
    proof(cases "ipassmt ifce")
    case None thus ?thesis
       apply(simp add: matches_ipassmt_iface_constrain_srcip_mexpr)
       apply(simp add: ipassmt_iface_constrain_srcip_mexpr_def
              primitive_matcher_generic.Iface_single_not[OF primitive_matcher_generic_common_matcher])
       done
     next
     case (Some ips)
       {  fix ips
          have "matches (common_matcher, α)
                 (MatchNot (match_list_to_match_expr (map (Match  Src  (uncurry IpAddrNetmask)) ips))) a p 
                 (p_src p  ipcidr_union_set (set ips))"
        apply(induction ips)
         apply(simp add: bunch_of_lemmata_about_matches ipcidr_union_set_uncurry; fail)
        apply(simp add: MatchOr_MatchNot)
        apply(simp add: ipcidr_union_set_uncurry)
        apply(simp add: match_simplematcher_SrcDst_not)
        apply(thin_tac _)
        by (simp add: ipt_iprange_to_set_uncurry_IpAddrNetmask)
       } note helper=this
       from Some show ?thesis
         apply(simp add: matches_ipassmt_iface_constrain_srcip_mexpr)
         apply(simp add: ipassmt_iface_constrain_srcip_mexpr_def primitive_matcher_generic.Iface_single_not[OF primitive_matcher_generic_common_matcher])
         apply(simp add: matches_DeMorgan)
         apply(simp add: helper)
         apply(simp add: primitive_matcher_generic.Iface_single_not[OF primitive_matcher_generic_common_matcher])
         by blast
     qed
     with IIface show ?thesis
      by(simp add: primitive_matcher_generic.Iface_single_not[OF primitive_matcher_generic_common_matcher]
                   primitive_matcher_generic.Iface_single[OF primitive_matcher_generic_common_matcher])
  qed(simp_all)
  
  
  (*helper2: used in induction base case*)
  private lemma matches_ipassmt_iface_constrain_srcip_mexpr_case_Iface:
        fixes ifce::iface
        assumes "ipassmt_sanity_nowildcards ipassmt"
        and "ips. ipassmt (Iface (p_iiface p)) = Some ips  p_src p  ipcidr_union_set (set ips)"
        shows   "matches (common_matcher, α) (ipassmt_iface_constrain_srcip_mexpr ipassmt ifce) a p 
                 matches (common_matcher, α) (Match (IIface ifce)) a p"
  proof -
    have "matches (common_matcher, α) (ipassmt_iface_constrain_srcip_mexpr ipassmt ifce) a p = match_iface ifce (p_iiface p)"
      proof(cases "ipassmt (Iface (p_iiface p))")
      case None
      from None show ?thesis
        proof(cases "ipassmt ifce")
          case None thus ?thesis by(simp add: matches_ipassmt_iface_constrain_srcip_mexpr)
          next
          case (Some a)
           from assms(1) have "¬ match_iface ifce (p_iiface p)"
           apply(rule ipassmt_sanity_nowildcards_match_iface)
            by(simp_all add: Some None)
          with Some show ?thesis by(simp add: matches_ipassmt_iface_constrain_srcip_mexpr)
        qed
      next
      case (Some x)
        with assms(2) have assms2: "p_src p  ipcidr_union_set (set x)" by(simp) (*unused*)
        show ?thesis
        proof(cases "ipassmt ifce")
          case None thus ?thesis by(simp add: matches_ipassmt_iface_constrain_srcip_mexpr)
          next
          case (Some y) with assms(2) have "(match_iface ifce (p_iiface p)  p_src p  ipcidr_union_set (set y)) = match_iface ifce (p_iiface p)"
            apply(cases ifce)
            apply(rename_tac ifce_str)
            apply(case_tac "ifce_str = (p_iiface p)")
             apply (simp add: match_iface_refl; fail)
            apply(simp)
            apply(subgoal_tac "¬ match_iface (Iface ifce_str) (p_iiface p)")
             apply(simp)
            using assms(1) by (metis domI iface.sel iface_is_wildcard_def ipassmt_sanity_nowildcards_def match_iface_case_nowildcard)
            with Some show ?thesis by(simp add: matches_ipassmt_iface_constrain_srcip_mexpr)
        qed
    qed
    thus ?thesis by(simp add: primitive_matcher_generic.Iface_single[OF primitive_matcher_generic_common_matcher])
  qed
    

  lemma matches_iiface_constrain:
       "normalized_nnf_match m  ipassmt_sanity_nowildcards ipassmt 
        (ips. ipassmt (Iface (p_iiface p)) = Some ips  p_src p  ipcidr_union_set (set ips)) 
        matches (common_matcher, α) (iiface_constrain ipassmt m) a p  matches (common_matcher, α) m a p"
    proof(induction m)
    case MatchAny thus ?case by simp
    next
    case (MatchNot m)
      hence IH: "normalized_nnf_match m  matches (common_matcher, α) (iiface_constrain ipassmt m) a p = matches (common_matcher, α) m a p" by blast
      with MatchNot.prems IH show ?case by(induction m) (simp_all add: iiface_constrain_matches_Primitive)
    next
    case(Match x) thus ?case
      proof(cases x)
        case (IIface ifce) with Match show ?thesis
        using matches_ipassmt_iface_constrain_srcip_mexpr_case_Iface by fastforce
      qed(simp_all)
    next
    case (MatchAnd m1 m2) thus ?case by(simp add: bunch_of_lemmata_about_matches)
    qed
end




subsection‹Sanity checking the assumption›
(* we need a good formulation of the assumption. the case stuff is so undefined for the None case …
   ∃-quantor is too strong
  Also holds if ∃ replaced by ∀*)
lemma "(ips. ipassmt (Iface (p_iiface p)) = Some ips  p_src p  ipcidr_union_set (set ips)) 
       (case ipassmt (Iface (p_iiface p)) of Some ips  p_src p  ipcidr_union_set (set ips))"
      "(case ipassmt (Iface (p_iiface p)) of Some ips  p_src p  ipcidr_union_set (set ips)) 
      (ips. ipassmt (Iface (p_iiface p)) = Some ips  p_src p  ipcidr_union_set (set ips))"
  by(cases "ipassmt (Iface (p_iiface p))",simp_all)+

text‹Sanity check:
      If we assume that there are no spoofed packets, spoofing protection is trivially fulfilled.›
lemma " p:: ('i::len,'pkt_ext) tagged_packet_scheme.
        Iface (p_iiface p)  dom ipassmt  p_src p  ipcidr_union_set (set (the (ipassmt (Iface (p_iiface p))))) 
       no_spoofing TYPE('pkt_ext) ipassmt rs"
  apply(simp add: no_spoofing_def)
  apply(clarify)
  apply(rename_tac iface ips p)
  apply(thin_tac "_,_ rs, Undecided α Decision FinalAllow") (*not needed*)
  apply(erule_tac x="pp_iiface := iface_sel iface" in allE)
  apply(auto)
  done

text‹Sanity check:
      If the firewall features spoofing protection and we look at a packet which was allowed by the firewall.
      Then the packet's src ip must be according to ipassmt. (case Some)
      We don't case about packets from an interface which are not defined in ipassmt. (case None)›
lemma 
  fixes p :: "('i::len,'pkt_ext) tagged_packet_scheme"
  shows "no_spoofing TYPE('pkt_ext) ipassmt rs  
      (common_matcher, in_doubt_allow),p rs, Undecided α Decision FinalAllow 
       case ipassmt (Iface (p_iiface p)) of Some ips  p_src p  ipcidr_union_set (set ips) | None  True"
  apply(simp add: no_spoofing_def)
  apply(case_tac "Iface (p_iiface p)  dom ipassmt")
   apply(erule_tac x="Iface (p_iiface p)" in ballE)
    apply(simp_all)
   apply(erule_tac x="p" in allE)
   apply(simp)
   apply fastforce
  by (simp add: domIff)






subsection‹Replacing Interfaces Completely›

text‹This is a stricter, true rewriting since it removes the interface match completely.
      However, it requires @{const ipassmt_sanity_disjoint}

thm ipassmt_sanity_disjoint_def

definition ipassmt_iface_replace_srcip_mexpr
  :: "'i::len ipassignment  iface  'i common_primitive match_expr" where
  "ipassmt_iface_replace_srcip_mexpr ipassmt ifce  case ipassmt ifce of
          None  Match (IIface ifce)
        | Some ips  (match_list_to_match_expr (map (Match  Src) (map (uncurry IpAddrNetmask) ips)))"


lemma matches_ipassmt_iface_replace_srcip_mexpr: 
    "matches (common_matcher, α) (ipassmt_iface_replace_srcip_mexpr ipassmt ifce) a p  (case ipassmt ifce of
            None  match_iface ifce (p_iiface p)
          | Some ips  p_src p  ipcidr_union_set (set ips)
          )"
proof(cases "ipassmt ifce")
case None thus ?thesis by(simp add: ipassmt_iface_replace_srcip_mexpr_def primitive_matcher_generic.Iface_single[OF primitive_matcher_generic_common_matcher])
next
case (Some ips)
  have "matches (common_matcher, α) (match_list_to_match_expr (map (Match  Src  (uncurry IpAddrNetmask)) ips)) a p 
       (mset ips. p_src p  (uncurry ipset_from_cidr m))" 
       by(simp add: match_list_to_match_expr_disjunction[symmetric]
                    match_list_matches match_simplematcher_SrcDst ipt_iprange_to_set_uncurry_IpAddrNetmask)
  with Some show ?thesis
    apply(simp add: ipassmt_iface_replace_srcip_mexpr_def bunch_of_lemmata_about_matches)
    apply(simp add: ipcidr_union_set_uncurry)
    done
qed


fun iiface_rewrite
  :: "'i::len ipassignment  'i common_primitive match_expr  'i common_primitive match_expr"
where
  "iiface_rewrite _       MatchAny = MatchAny" |
  "iiface_rewrite ipassmt (Match (IIface ifce)) = ipassmt_iface_replace_srcip_mexpr ipassmt ifce" |
  "iiface_rewrite ipassmt (Match a) = Match a" |
  "iiface_rewrite ipassmt (MatchNot m) = MatchNot (iiface_rewrite ipassmt m)" |
  "iiface_rewrite ipassmt (MatchAnd m1 m2) = MatchAnd (iiface_rewrite ipassmt m1) (iiface_rewrite ipassmt m2)"


context
begin
  (*helper1: used in induction case MatchNot*)
  private lemma iiface_rewrite_matches_Primitive:
          "matches (common_matcher, α) (MatchNot (iiface_rewrite ipassmt (Match x))) a p = matches (common_matcher, α) (MatchNot (Match x)) a p 
           matches (common_matcher, α) (iiface_rewrite ipassmt (Match x)) a p = matches (common_matcher, α) (Match x) a p"
  proof(cases x)
  case (IIface ifce)
    have "(matches (common_matcher, α) (MatchNot (ipassmt_iface_replace_srcip_mexpr ipassmt ifce)) a p = (¬ match_iface ifce (p_iiface p))) 
      (matches (common_matcher, α) (ipassmt_iface_replace_srcip_mexpr ipassmt ifce) a p = match_iface ifce (p_iiface p))"
    proof(cases "ipassmt ifce")
    case None thus ?thesis
       apply(simp add: matches_ipassmt_iface_replace_srcip_mexpr)
       apply(simp add: ipassmt_iface_replace_srcip_mexpr_def primitive_matcher_generic.Iface_single_not[OF primitive_matcher_generic_common_matcher])
       done
     next
     case (Some ips)
       {  fix ips
          have "matches (common_matcher, α)
                 (MatchNot (match_list_to_match_expr (map (Match  Src  (uncurry IpAddrNetmask)) ips))) a p 
                 (p_src p  ipcidr_union_set (set ips))"
        apply(induction ips)
         apply(simp add: bunch_of_lemmata_about_matches ipcidr_union_set_uncurry)
        apply(simp add: MatchOr_MatchNot)
        apply(simp add: ipcidr_union_set_uncurry)
        apply(simp add: match_simplematcher_SrcDst_not)
        apply(thin_tac _)
        apply(simp add: ipt_iprange_to_set_uncurry_IpAddrNetmask)
        done
       } note helper=this
       from Some show ?thesis
         apply(simp add: matches_ipassmt_iface_replace_srcip_mexpr)
         apply(simp add: ipassmt_iface_replace_srcip_mexpr_def)
         apply(simp add: helper)
         done
     qed
     with IIface show ?thesis
      by(simp add: primitive_matcher_generic.Iface_single_not[OF primitive_matcher_generic_common_matcher]
            primitive_matcher_generic.Iface_single[OF primitive_matcher_generic_common_matcher])
  qed(simp_all)


  (*helper2: used in induction base case*)
  private lemma matches_ipassmt_iface_replace_srcip_mexpr_case_Iface:
        fixes ifce::iface
        assumes "ipassmt_sanity_nowildcards ipassmt"
            and "ipassmt_sanity_disjoint ipassmt"
            and "ipassmt (Iface (p_iiface p)) = Some p_ips  p_src p  ipcidr_union_set (set p_ips)"
        shows   "matches (common_matcher, α) (ipassmt_iface_replace_srcip_mexpr ipassmt ifce) a p 
                 matches (common_matcher, α) (Match (IIface ifce)) a p"
  proof -
    have "matches (common_matcher, α) (ipassmt_iface_replace_srcip_mexpr ipassmt ifce) a p = match_iface ifce (p_iiface p)"
      proof -
        show ?thesis
        proof(cases "ipassmt ifce")
          case None thus ?thesis by(simp add: matches_ipassmt_iface_replace_srcip_mexpr)
          next
          case (Some y) with assms(2) have "p_src p  ipcidr_union_set (set y) = match_iface ifce (p_iiface p)"
            using assms(1) assms(3) ipassmt_disjoint_matcheq_iifce_srcip by blast
            with Some show ?thesis by(simp add: matches_ipassmt_iface_replace_srcip_mexpr)
        qed
    qed
    thus ?thesis by(simp add: primitive_matcher_generic.Iface_single[OF primitive_matcher_generic_common_matcher])
  qed



  lemma matches_iiface_rewrite:
       "normalized_nnf_match m  ipassmt_sanity_nowildcards ipassmt  ipassmt_sanity_disjoint ipassmt 
        (p_ips. ipassmt (Iface (p_iiface p)) = Some p_ips  p_src p  ipcidr_union_set (set p_ips)) 
        matches (common_matcher, α) (iiface_rewrite ipassmt m) a p  matches (common_matcher, α) m a p"
    proof(induction m)
    case MatchAny thus ?case by simp
    next
    case (MatchNot m)
      hence IH: "normalized_nnf_match m 
        matches (common_matcher, α) (iiface_rewrite ipassmt m) a p =matches (common_matcher, α) m a p" by blast
      with MatchNot.prems IH show ?case by(induction m) (simp_all add: iiface_rewrite_matches_Primitive)
    next
    case(Match x) thus ?case
      proof(cases x)
        case (IIface ifce) with Match show ?thesis
        apply(cases "ipassmt (Iface (p_iiface p))")
         prefer 2
          apply(simp add: matches_ipassmt_iface_replace_srcip_mexpr_case_Iface; fail)
        by auto
      qed(simp_all)
    next
    case (MatchAnd m1 m2) thus ?case by(simp add: bunch_of_lemmata_about_matches)
    qed

end

  text‹Finally, we show that @{const ipassmt_sanity_disjoint} is really needed.›
  lemma iface_replace_needs_ipassmt_disjoint:
    assumes "ipassmt_sanity_nowildcards ipassmt"
    and iface_replace: " ifce p:: 'i::len tagged_packet.
          (matches (common_matcher, α) (ipassmt_iface_replace_srcip_mexpr ipassmt ifce) a p  matches (common_matcher, α) (Match (IIface ifce)) a p)" 
    shows "ipassmt_sanity_disjoint ipassmt"
  unfolding ipassmt_sanity_disjoint_def
  proof(intro ballI impI)
    fix i1 i2
    assume "i1  dom ipassmt" and "i2  dom ipassmt" and "i1  i2"
    from i1  dom ipassmt obtain i1_ips where i1_ips: "ipassmt i1 = Some i1_ips" by blast
    from i2  dom ipassmt obtain i2_ips where i2_ips: "ipassmt i2 = Some i2_ips" by blast

    { fix p :: "'i tagged_packet"
      from iface_replace[of  i1 "p p_iiface := iface_sel i2"] have
        "(p_src p  ipcidr_union_set (set i2_ips)  (p_src p  ipcidr_union_set (set i1_ips)) = match_iface i1 (iface_sel i2))"
      apply(simp add: primitive_matcher_generic.Iface_single[OF primitive_matcher_generic_common_matcher] i1  dom ipassmt)
      apply(simp add: matches_ipassmt_iface_replace_srcip_mexpr i1_ips)
      done
      with i1  i2 have "¬ (p_src p  ipcidr_union_set (set i2_ips)  (p_src p  ipcidr_union_set (set i1_ips)))"
        by (metis i1  dom ipassmt assms(1) iface.exhaust_sel iface_is_wildcard_def ipassmt_sanity_nowildcards_def match_iface_case_nowildcard) 
    }
    hence "¬ (src  ipcidr_union_set (set i2_ips)  (src  ipcidr_union_set (set i1_ips)))"
      for src
      apply(simp)
      by (metis simple_packet.select_convs(3))

    thus "ipcidr_union_set (set (the (ipassmt i1)))  ipcidr_union_set (set (the (ipassmt i2))) = {}"
      apply(simp add: i1_ips i2_ips)
      by blast
  qed

end

Theory Optimizing

theory Optimizing
imports Semantics_Ternary
begin


section‹Optimizing›

subsection‹Removing Shadowed Rules›
text‹Note: there is no executable code for rmshadow at the moment›

text‹Assumes: @{term "simple_ruleset"}
fun rmshadow :: "('a, 'p) match_tac  'a rule list  'p set  'a rule list" where
  "rmshadow _ [] _ = []" |
  "rmshadow γ ((Rule m a)#rs) P = (if (pP. ¬ matches γ m a p)
    then 
      rmshadow γ rs P
    else
      (Rule m a) # (rmshadow γ rs {p  P. ¬ matches γ m a p}))"
(*needs a ruleset without log and empty*)



subsubsection‹Soundness›
  lemma rmshadow_sound: 
    "simple_ruleset rs  p  P  approximating_bigstep_fun γ p (rmshadow γ rs P) = approximating_bigstep_fun γ p rs"
  proof(induction rs arbitrary: P)
  case Nil thus ?case by simp
  next
  case (Cons r rs)
    let ?fw="approximating_bigstep_fun γ" ― ‹firewall semantics›
    let ?rm="rmshadow γ"
    let ?match="matches γ (get_match r) (get_action r)"
    let ?set="{p  P. ¬ ?match p}"
    from Cons.IH Cons.prems have IH: "?fw p (?rm rs P) = ?fw p rs" by (simp add: simple_ruleset_def)
    from Cons.IH[of "?set"] Cons.prems have IH': "p  ?set  ?fw p (?rm rs ?set) = ?fw p rs" by (simp add: simple_ruleset_def)
    from Cons show ?case
      proof(cases "pP. ¬ ?match p") ― ‹the if-condition of rmshadow›
      case True
        from True have 1: "?rm (r#rs) P = ?rm rs P" 
          apply(cases r)
          apply(rename_tac m a)
          apply(clarify)
          apply(simp)
          done
        from True Cons.prems have "?fw p (r # rs) = ?fw p rs"
          apply(cases r)
          apply(rename_tac m a)
          apply(simp add: fun_eq_iff)
          apply(clarify)
          apply(rule just_show_all_approximating_bigstep_fun_equalities_with_start_Undecided)
          apply(simp)
          done
        from this IH have "?fw p (?rm rs P) = ?fw p (r#rs) " by simp
        thus "?fw p (?rm (r#rs) P) = ?fw p (r#rs) " using 1 by simp
      next
      case False ― ‹else›
        have "?fw p (r # (?rm rs ?set)) = ?fw p (r # rs)"
          proof(cases "p  ?set")
            case True
              from True IH' show "?fw p (r # (?rm rs ?set)) = ?fw p (r#rs)" 
                apply(cases r)
                apply(rename_tac m a)
                apply(simp add: fun_eq_iff)
                apply(clarify)
                apply(rule just_show_all_approximating_bigstep_fun_equalities_with_start_Undecided)
                apply(simp)
                done
            next
            case False
              from False Cons.prems have "?match p" by simp
              from Cons.prems have "get_action r = Accept  get_action r = Drop" by(simp add: simple_ruleset_def)
              from this ?match pshow "?fw p (r # (?rm rs ?set)) = ?fw p (r#rs)"
                apply(cases r)
                apply(rename_tac m a)
                apply(simp add: fun_eq_iff)
                apply(clarify)
                apply(rename_tac s)
                apply(rule just_show_all_approximating_bigstep_fun_equalities_with_start_Undecided)
                apply(simp split:action.split)
                apply fast
                done
          qed
        from False this show ?thesis 
          apply(cases r)
          apply(rename_tac m a)
          apply(simp add: fun_eq_iff)
          apply(clarify)
          apply(rule just_show_all_approximating_bigstep_fun_equalities_with_start_Undecided)
          apply(simp)
          done
    qed
  qed



subsection‹Removing rules which cannot apply›

fun rmMatchFalse :: "'a rule list  'a rule list" where
  "rmMatchFalse [] = []" |
  "rmMatchFalse ((Rule (MatchNot MatchAny) _)#rs) = rmMatchFalse rs" |
  "rmMatchFalse (r#rs) = r # rmMatchFalse rs"

lemma rmMatchFalse_correct: "approximating_bigstep_fun γ p (rmMatchFalse rs) s = approximating_bigstep_fun γ p rs s"
  proof-
    { fix m::"'a match_expr" and a and rs
      assume assm: "m  MatchNot MatchAny"
      have "rmMatchFalse (Rule m a # rs) = Rule m a # (rmMatchFalse rs)" (is ?hlp)
      proof(cases m)
        case (MatchNot mexpr) with assm show ?hlp by(cases mexpr) simp_all
        qed(simp_all)
    } note rmMatchFalse_helper=this
  show ?thesis
    proof(induction γ p rs s rule: approximating_bigstep_fun_induct)
      case Empty thus ?case by(simp)
      next
      case Decision thus ?case by(metis Decision_approximating_bigstep_fun)
      next
      case (Nomatch γ p m a) thus ?case
        by(cases "m = MatchNot MatchAny") (simp_all add: rmMatchFalse_helper)
      next
      case (Match γ p m a rs) 
        from Match(1) have "m  MatchNot MatchAny" using bunch_of_lemmata_about_matches(3) by fast
        with Match rmMatchFalse_helper show ?case by(simp split:action.split)
    qed
  qed



text‹We can stop after a default rule (a rule which matches anything) is observed.›
fun cut_off_after_match_any :: "'a rule list  'a rule list" where
  "cut_off_after_match_any [] = []" |
  "cut_off_after_match_any (Rule m a # rs) =
    (if m = MatchAny  (a = Accept  a = Drop  a = Reject)
     then [Rule m a] else Rule m a # cut_off_after_match_any rs)"

lemma cut_off_after_match_any:
  "approximating_bigstep_fun γ p (cut_off_after_match_any rs) s = approximating_bigstep_fun γ p rs s"
  apply(rule just_show_all_approximating_bigstep_fun_equalities_with_start_Undecided)
  apply(induction γ p rs s rule: approximating_bigstep_fun.induct)
    apply(simp; fail)
   apply(simp; fail)
  by(simp split: action.split action.split_asm add: bunch_of_lemmata_about_matches(2))

lemma cut_off_after_match_any_simplers: "simple_ruleset rs  simple_ruleset (cut_off_after_match_any rs)"
  by(induction rs rule: cut_off_after_match_any.induct) (simp_all add: simple_ruleset_def)

lemma cut_off_after_match_any_preserve_matches:
  " r  set rs. P (get_match r)   r  set (cut_off_after_match_any rs). P (get_match r)"
  apply(induction rs rule: cut_off_after_match_any.induct)
   apply(simp; fail)
  by(auto simp add: simple_ruleset_def)

end

Theory Transform

section‹Optimizing and Normalizing Primitives›
theory Transform
imports Common_Primitive_Lemmas
        "../Semantics_Ternary/Semantics_Ternary"
        "../Semantics_Ternary/Negation_Type_Matching"
        Ports_Normalize
        IpAddresses_Normalize
        Interfaces_Normalize
        Protocols_Normalize
        "../Common/Remdups_Rev"
        Interface_Replace
        "../Semantics_Ternary/Optimizing"
begin

text‹This transform theory plugs a lot of stuff together. We perform several normalization and
  optimization steps on complete firewall rulesets. We show that it preserves the semantics and also,
  that structural properties are preserved. For example, if you normalize interfaces and afterwards
  normalize protocols, the interfaces remain normalized and no new interfaces are added when 
  doing the protocol normalization.›


(*Maintainer note: we plug a lot of lemmata together to show that structural properties are preserved.
  Yes, there is a huge set of apply style in there but there is no magic happening, it is just
  pushing through invariants about structural properties.*)

definition compress_normalize_besteffort
  :: "'i::len common_primitive match_expr  'i common_primitive match_expr option" where
   "compress_normalize_besteffort m  compress_normalize_primitive_monad
          [compress_normalize_protocols,
           compress_normalize_input_interfaces,
           compress_normalize_output_interfaces] m"  
  
context begin
  private lemma compress_normalize_besteffort_normalized:
  "f  set [compress_normalize_protocols,
            compress_normalize_input_interfaces,
            compress_normalize_output_interfaces] 
         normalized_nnf_match m  f m = Some m'  normalized_nnf_match m'"
    apply(simp)
    apply(elim disjE)
      using compress_normalize_protocols_nnf apply blast
     using compress_normalize_input_interfaces_nnf apply blast
    using compress_normalize_output_interfaces_nnf apply blast
    done
  private lemma compress_normalize_besteffort_matches:
    assumes generic: "primitive_matcher_generic β"
    shows "f  set [compress_normalize_protocols,
                    compress_normalize_input_interfaces,
                    compress_normalize_output_interfaces] 
           normalized_nnf_match m 
           f m = Some m' 
           matches (β, α) m' a p = matches (β, α) m a p"
    apply(simp)
    apply(elim disjE)
      using primitive_matcher_generic.compress_normalize_protocols_Some[OF generic] apply blast
     using compress_normalize_input_interfaces_Some[OF generic] apply blast
    using compress_normalize_output_interfaces_Some[OF generic] apply blast
    done
  
  
  lemma compress_normalize_besteffort_Some: 
    assumes generic: "primitive_matcher_generic β"
    shows "normalized_nnf_match m 
           compress_normalize_besteffort m = Some m' 
           matches (β, α) m' a p = matches (β, α) m a p"
    unfolding compress_normalize_besteffort_def
    apply(rule compress_normalize_primitive_monad)
    using compress_normalize_besteffort_normalized compress_normalize_besteffort_matches[OF generic] by blast+
  lemma compress_normalize_besteffort_None:
    assumes generic: "primitive_matcher_generic β"
    shows "normalized_nnf_match m 
           compress_normalize_besteffort m = None 
           ¬ matches (β, α) m a p"
  proof -
   have notmatches: "f  set [compress_normalize_protocols, compress_normalize_input_interfaces, compress_normalize_output_interfaces] 
           normalized_nnf_match m  f m = None  ¬ matches (β, α) m a p" for f m
      apply(simp)
      using primitive_matcher_generic.compress_normalize_protocols_None[OF generic]
            compress_normalize_input_interfaces_None[OF generic]
            compress_normalize_output_interfaces_None[OF generic] by blast
   show "normalized_nnf_match m  compress_normalize_besteffort m = None  ¬ matches (β, α) m a p"
     unfolding compress_normalize_besteffort_def
     apply(rule compress_normalize_primitive_monad_None)
         using compress_normalize_besteffort_normalized
               compress_normalize_besteffort_matches[OF generic]
               notmatches by blast+
  qed 
  lemma compress_normalize_besteffort_nnf:
    "normalized_nnf_match m 
     compress_normalize_besteffort m = Some m' 
     normalized_nnf_match m'"
    unfolding compress_normalize_besteffort_def
    apply(rule compress_normalize_primitive_monad)
       using compress_normalize_besteffort_normalized
             compress_normalize_besteffort_matches[OF primitive_matcher_generic_common_matcher]
             by blast+
  
  lemma compress_normalize_besteffort_not_introduces_Iiface:
      "¬ has_disc is_Iiface m  normalized_nnf_match m  compress_normalize_besteffort m = Some m' 
       ¬ has_disc is_Iiface m'"
    unfolding compress_normalize_besteffort_def
    apply(rule compress_normalize_primitive_monad_preserves[THEN conjunct2])
        apply(drule(3) compress_normalize_besteffort_normalized)
       apply(auto dest: compress_normalize_input_interfaces_not_introduces_Iiface
                        compress_normalize_protocols_hasdisc
                        compress_normalize_output_interfaces_hasdisc)
    done
  lemma compress_normalize_besteffort_not_introduces_Oiface:
      "¬ has_disc is_Oiface m  normalized_nnf_match m  compress_normalize_besteffort m = Some m' 
       ¬ has_disc is_Oiface m'"
    unfolding compress_normalize_besteffort_def
    apply(rule compress_normalize_primitive_monad_preserves[THEN conjunct2])
        apply(drule(3) compress_normalize_besteffort_normalized)
       apply(auto dest: compress_normalize_output_interfaces_hasdisc
                        compress_normalize_output_interfaces_not_introduces_Oiface
                        compress_normalize_protocols_hasdisc
                        compress_normalize_input_interfaces_hasdisc)
    done
  
  lemma compress_normalize_besteffort_not_introduces_Iiface_negated:
      "¬ has_disc_negated is_Iiface False m  normalized_nnf_match m  compress_normalize_besteffort m = Some m' 
       ¬ has_disc_negated is_Iiface False m'"
    unfolding compress_normalize_besteffort_def
    apply(rule compress_normalize_primitive_monad_preserves[THEN conjunct2])
        apply(drule(3) compress_normalize_besteffort_normalized)
       apply(auto dest: compress_normalize_besteffort_normalized compress_normalize_input_interfaces_not_introduces_Iiface_negated
                        compress_normalize_protocols_hasdisc_negated
                        compress_normalize_output_interfaces_hasdisc_negated)
    done
  lemma compress_normalize_besteffort_not_introduces_Oiface_negated:
      "¬ has_disc_negated is_Oiface False m  normalized_nnf_match m  compress_normalize_besteffort m = Some m' 
       ¬ has_disc_negated is_Oiface False m'"
    unfolding compress_normalize_besteffort_def
    apply(rule compress_normalize_primitive_monad_preserves[THEN conjunct2])
        apply(drule(3) compress_normalize_besteffort_normalized)
       apply(auto dest: compress_normalize_output_interfaces_not_introduces_Oiface_negated
                        compress_normalize_input_interfaces_hasdisc_negated
                        compress_normalize_protocols_hasdisc_negated)
    done
  lemma compress_normalize_besteffort_not_introduces_Prot_negated:
      "¬ has_disc_negated is_Prot False m  normalized_nnf_match m  compress_normalize_besteffort m = Some m' 
       ¬ has_disc_negated is_Prot False m'"
    unfolding compress_normalize_besteffort_def
    apply(rule compress_normalize_primitive_monad_preserves[THEN conjunct2])
        apply(drule(3) compress_normalize_besteffort_normalized)
       apply(auto dest: compress_normalize_input_interfaces_hasdisc_negated
                        compress_normalize_protocols_not_introduces_Prot_negated
                        compress_normalize_output_interfaces_hasdisc_negated)
    done
  lemma compress_normalize_besteffort_hasdisc:
      "¬ has_disc disc m  (a. ¬ disc (IIface a))  (a. ¬ disc (OIface a))  (a. ¬ disc (Prot a)) 
       normalized_nnf_match m  compress_normalize_besteffort m = Some m' 
       normalized_nnf_match m'  ¬ has_disc disc m'"
    unfolding compress_normalize_besteffort_def
    apply(rule compress_normalize_primitive_monad_preserves)
        apply(drule(3) compress_normalize_besteffort_normalized)
       apply(auto dest: compress_normalize_input_interfaces_hasdisc
                        compress_normalize_output_interfaces_hasdisc
                        compress_normalize_protocols_hasdisc)
    done
  lemma compress_normalize_besteffort_hasdisc_negated:
      "¬ has_disc_negated disc False m 
       (a. ¬ disc (IIface a))  (a. ¬ disc (OIface a))  (a. ¬ disc (Prot a)) 
       normalized_nnf_match m  compress_normalize_besteffort m = Some m' 
       normalized_nnf_match m'  ¬ has_disc_negated disc False m'"
       (*due to protocols, we can only show for neg := False*)
    unfolding compress_normalize_besteffort_def
    apply(rule compress_normalize_primitive_monad_preserves)
        apply(drule(3) compress_normalize_besteffort_normalized)
       apply(simp split: option.split_asm)
       using compress_normalize_input_interfaces_hasdisc_negated
             compress_normalize_output_interfaces_hasdisc_negated
             compress_normalize_protocols_hasdisc_negated apply blast
    apply simp_all
    done
  lemma compress_normalize_besteffort_preserves_normalized_n_primitive:
    "normalized_n_primitive (disc, sel) P m 
     (a. ¬ disc (IIface a))  (a. ¬ disc (OIface a))  (a. ¬ disc (Prot a)) 
     normalized_nnf_match m  compress_normalize_besteffort m = Some m' 
     normalized_nnf_match m'  normalized_n_primitive (disc, sel) P m'"
    unfolding compress_normalize_besteffort_def
    apply(rule compress_normalize_primitive_monad_preserves)
        apply(drule(3) compress_normalize_besteffort_normalized)
       apply(auto dest: compress_normalize_input_interfaces_preserves_normalized_n_primitive
             compress_normalize_output_interfaces_preserves_normalized_n_primitive
             compress_normalize_protocols_preserves_normalized_n_primitive)
    done
end

section‹Transforming rulesets›

subsection‹Optimizations›

lemma approximating_bigstep_fun_remdups_rev:
  "approximating_bigstep_fun γ p (remdups_rev rs) s = approximating_bigstep_fun γ p rs s"
  proof(induction γ p rs s rule: approximating_bigstep_fun.induct)
    case 1 thus ?case by(simp add: remdups_rev_def)
    next
    case 2 thus ?case by (simp add: Decision_approximating_bigstep_fun)
    next
    case (3 γ p m a rs) thus ?case
      proof(cases "matches γ m a p")
        case False with 3 show ?thesis
         by(simp add: remdups_rev_fst remdups_rev_removeAll not_matches_removeAll) 
        next
        case True
        { fix rs s
          have "approximating_bigstep_fun γ p (filter ((≠) (Rule m Log)) rs) s = approximating_bigstep_fun γ p rs s"
          proof(induction γ p rs s rule: approximating_bigstep_fun_induct)
          qed(auto simp add: Decision_approximating_bigstep_fun split: action.split)
        } note helper_Log=this
        { fix rs s
          have "approximating_bigstep_fun γ p (filter ((≠) (Rule m Empty)) rs) s = approximating_bigstep_fun γ p rs s"
          proof(induction γ p rs s rule: approximating_bigstep_fun_induct)
          qed(auto simp add: Decision_approximating_bigstep_fun split: action.split)
        } note helper_Empty=this
        from True 3 show ?thesis
          apply(simp add: remdups_rev_fst split: action.split)
          apply(safe)
             apply(simp_all)
           apply(simp_all add: remdups_rev_removeAll)
           apply(simp_all add: removeAll_filter_not_eq helper_Empty helper_Log)
          done
        qed
  qed

lemma remdups_rev_simplers: "simple_ruleset rs  simple_ruleset (remdups_rev rs)"
  by(induction rs) (simp_all add: remdups_rev_def simple_ruleset_def)

lemma remdups_rev_preserve_matches:
  "rset rs. P (get_match r)  rset (remdups_rev rs). P (get_match r)"
  by(induction rs) (simp_all add: remdups_rev_def simple_ruleset_def)


subsection‹Optimize and Normalize to NNF form›

(*without normalize_rules_dnf, the result cannot be normalized as optimize_primitive_univ can contain MatchNot MatchAny*)
definition transform_optimize_dnf_strict :: "'i::len common_primitive rule list  'i common_primitive rule list" where 
    "transform_optimize_dnf_strict = cut_off_after_match_any 
        (optimize_matches opt_MatchAny_match_expr  
        normalize_rules_dnf  (optimize_matches (opt_MatchAny_match_expr  optimize_primitive_univ)))"
  

theorem transform_optimize_dnf_strict_structure:
  assumes simplers: "simple_ruleset rs" and wfα: "wf_unknown_match_tac α"
  shows "simple_ruleset (transform_optimize_dnf_strict rs)"
  and " r  set rs. ¬ has_disc disc (get_match r) 
           r  set (transform_optimize_dnf_strict rs). ¬ has_disc disc (get_match r)"
  and " r  set (transform_optimize_dnf_strict rs). normalized_nnf_match (get_match r)"
  and " r  set rs. normalized_n_primitive disc_sel f (get_match r) 
         r  set (transform_optimize_dnf_strict rs). normalized_n_primitive disc_sel f (get_match r)"
  and " r  set rs. ¬ has_disc_negated disc neg (get_match r) 
         r  set (transform_optimize_dnf_strict rs). ¬ has_disc_negated disc neg (get_match r)"
  proof -
    show simplers_transform: "simple_ruleset (transform_optimize_dnf_strict rs)"
      unfolding transform_optimize_dnf_strict_def
      using simplers by (simp add: cut_off_after_match_any_simplers
          optimize_matches_simple_ruleset simple_ruleset_normalize_rules_dnf)

    define transform_optimize_dnf_strict_inner
      where "transform_optimize_dnf_strict_inner =
        optimize_matches (opt_MatchAny_match_expr :: 'a common_primitive match_expr  'a common_primitive match_expr)  
          normalize_rules_dnf  (optimize_matches (opt_MatchAny_match_expr  optimize_primitive_univ))"
    have inner_outer: "transform_optimize_dnf_strict = (cut_off_after_match_any  transform_optimize_dnf_strict_inner)"
      by(auto simp add: transform_optimize_dnf_strict_def transform_optimize_dnf_strict_inner_def)
    have tf1: "transform_optimize_dnf_strict_inner (r#rs) =
      (optimize_matches opt_MatchAny_match_expr (normalize_rules_dnf (optimize_matches (opt_MatchAny_match_expr  optimize_primitive_univ) [r])))@
        transform_optimize_dnf_strict_inner rs" for r rs
      unfolding transform_optimize_dnf_strict_inner_def
      apply(simp)
      apply(subst optimize_matches_fst)
      apply(simp add: normalize_rules_dnf_append optimize_matches_append)
      done

    ― ‹if the individual optimization functions preserve a property, then the whole thing does›
    { fix P :: "'a::len common_primitive match_expr  bool"
      assume p1: "m. P m  P (optimize_primitive_univ m)"
      assume p2: "m. P m  P (opt_MatchAny_match_expr m)"
      assume p3: "m. P m  (m'  set (normalize_match m). P m')"
      { fix rs
        have " r  set rs. P (get_match r) 
           r  set (optimize_matches (opt_MatchAny_match_expr  optimize_primitive_univ) rs). P (get_match r)"
          apply(rule optimize_matches_preserves)
          using p1 p2 by simp
      } note opt1=this
      { fix rs
        have " r  set rs. P (get_match r)   r  set (normalize_rules_dnf rs). P (get_match r)"
        apply(induction rs rule: normalize_rules_dnf.induct)
         apply(simp; fail)
        apply(simp)
        apply(safe)
         apply(simp_all)
        using p3 by(simp)
      } note opt2=this
      { fix rs
        have " r  set rs. P (get_match r) 
           r  set (optimize_matches opt_MatchAny_match_expr rs). P (get_match r)"
          apply(rule optimize_matches_preserves)
          using p2 by simp
      } note opt3=this
      have " r   set rs. P (get_match r) 
         r  set (transform_optimize_dnf_strict rs). P (get_match r)"
        unfolding transform_optimize_dnf_strict_def
        apply(drule opt1)
        apply(drule opt2)
        apply(drule opt3)
        using cut_off_after_match_any_preserve_matches by auto
    } note matchpred_rule=this

    { fix m
      have "¬ has_disc disc m  ¬ has_disc disc (optimize_primitive_univ m)"
      by(induction m rule: optimize_primitive_univ.induct) (simp_all)
    }  moreover { fix m
      have "¬ has_disc disc m  (m'  set (normalize_match m). ¬ has_disc disc m')"
        using normalize_match_preserves_nodisc by fast
    } ultimately show " r  set rs. ¬ has_disc disc (get_match r) 
       r  set (transform_optimize_dnf_strict rs). ¬ has_disc disc (get_match r)"
      using not_has_disc_opt_MatchAny_match_expr matchpred_rule[of "λm. ¬ has_disc disc m"] by fast

    { fix m
      have "¬ has_disc_negated disc neg m  ¬ has_disc_negated disc neg (optimize_primitive_univ m)"
      apply(induction disc neg m rule: has_disc_negated.induct)
            apply(simp_all)
      apply(rename_tac a)
      apply(subgoal_tac "optimize_primitive_univ (Match a) = Match a  optimize_primitive_univ (Match a) = MatchAny")
       apply safe
        apply simp_all
      using optimize_primitive_univ_unchanged_primitives by blast
    }  with not_has_disc_negated_opt_MatchAny_match_expr not_has_disc_normalize_match show
      " r  set rs. ¬ has_disc_negated disc neg (get_match r) 
         r  set (transform_optimize_dnf_strict rs). ¬ has_disc_negated disc neg (get_match r)"
      using matchpred_rule[of "λm. ¬ has_disc_negated disc neg m"] by fast
   
   { fix P and a::"'a common_primitive"
     have "(optimize_primitive_univ (Match a)) = (Match a)  (optimize_primitive_univ (Match a)) = MatchAny"
       by(induction "(Match a)" rule: optimize_primitive_univ.induct) (auto)
     hence "((optimize_primitive_univ (Match a)) = Match a  P a)  (optimize_primitive_univ (Match a) = MatchAny  P a)  P a" by blast
   } note optimize_primitive_univ_match_cases=this

   { fix m
      have "normalized_n_primitive disc_sel f m  normalized_n_primitive disc_sel f (optimize_primitive_univ m)"
      apply(induction disc_sel f m rule: normalized_n_primitive.induct)
            apply(simp_all split: if_split_asm)
        apply(rule optimize_primitive_univ_match_cases, simp_all)+
      done
    }  moreover { fix m
      have "normalized_n_primitive disc_sel f m  (m'  set (normalize_match m). normalized_n_primitive disc_sel f  m')"
      using normalize_match_preserves_normalized_n_primitive by blast
    } ultimately show " r  set rs. normalized_n_primitive disc_sel f (get_match r)  
         r  set (transform_optimize_dnf_strict rs). normalized_n_primitive disc_sel f (get_match r)"
      using matchpred_rule[of "λm. normalized_n_primitive disc_sel f m"] normalized_n_primitive_opt_MatchAny_match_expr by fast
    

    { fix rs::"'a::len common_primitive rule list"
      from normalize_rules_dnf_normalized_nnf_match[of "rs"]
      have "x  set (normalize_rules_dnf rs). normalized_nnf_match (get_match x)" .
      hence "r  set (optimize_matches opt_MatchAny_match_expr (normalize_rules_dnf rs)). normalized_nnf_match (get_match r)"
        apply -
        apply(rule optimize_matches_preserves)
        using normalized_nnf_match_opt_MatchAny_match_expr by blast
    } 
    from this have " r  set (transform_optimize_dnf_strict_inner rs). normalized_nnf_match (get_match r)"
      unfolding transform_optimize_dnf_strict_inner_def by simp
    thus " r  set (transform_optimize_dnf_strict rs). normalized_nnf_match (get_match r)"
      unfolding inner_outer
      apply simp
      apply(rule cut_off_after_match_any_preserve_matches)
      .
  qed

theorem transform_optimize_dnf_strict:
  assumes simplers: "simple_ruleset rs" and wfα: "wf_unknown_match_tac α"
  shows "(common_matcher, α),p transform_optimize_dnf_strict rs, s α t  (common_matcher, α),p rs, s α t"
  proof -
    let ="(common_matcher, α)"
    let ?fw="λrs. approximating_bigstep_fun  p rs s"

    have simplers_transform: "simple_ruleset (transform_optimize_dnf_strict rs)"
      unfolding transform_optimize_dnf_strict_def
      using simplers by (simp add: cut_off_after_match_any_simplers 
                                    optimize_matches_simple_ruleset simple_ruleset_normalize_rules_dnf)

    have simplers1: "simple_ruleset (optimize_matches (opt_MatchAny_match_expr  optimize_primitive_univ) rs)"
      using simplers optimize_matches_simple_ruleset by (metis)

    have 1: ",p rs, s α t  ?fw rs = t"
      using approximating_semantics_iff_fun_good_ruleset[OF simple_imp_good_ruleset[OF simplers]] by fast

    have "?fw rs = ?fw (optimize_matches (opt_MatchAny_match_expr  optimize_primitive_univ) rs)"
      apply(rule optimize_matches[symmetric])
      using optimize_primitive_univ_correct_matchexpr opt_MatchAny_match_expr_correct by (metis comp_apply)
    also have " = ?fw (normalize_rules_dnf (optimize_matches (opt_MatchAny_match_expr  optimize_primitive_univ) rs))"
      apply(rule normalize_rules_dnf_correct[symmetric])
      using simplers1 by (metis good_imp_wf_ruleset simple_imp_good_ruleset)
    also have " = ?fw (optimize_matches opt_MatchAny_match_expr (normalize_rules_dnf (optimize_matches (opt_MatchAny_match_expr  optimize_primitive_univ) rs)))"
      apply(rule optimize_matches[symmetric])
      using opt_MatchAny_match_expr_correct by (metis)
    finally have rs: "?fw rs = ?fw (transform_optimize_dnf_strict rs)"
      unfolding transform_optimize_dnf_strict_def by(simp add: cut_off_after_match_any)

    have 2: "?fw (transform_optimize_dnf_strict rs) = t  ,p transform_optimize_dnf_strict rs, s α t "
      using approximating_semantics_iff_fun_good_ruleset[OF simple_imp_good_ruleset[OF simplers_transform], symmetric] by fast
    from 1 2 rs show ",p transform_optimize_dnf_strict rs, s α t  ,p rs, s α t" by simp
qed


subsection‹Abstracting over unknowns›

definition transform_remove_unknowns_generic
  :: "('a, 'packet) match_tac  'a rule list  'a rule list"
where 
    "transform_remove_unknowns_generic γ = optimize_matches_a (remove_unknowns_generic γ) "

theorem transform_remove_unknowns_generic:
  assumes simplers: "simple_ruleset rs"
      and wfα: "wf_unknown_match_tac α" and packet_independent_α: "packet_independent_α α"
      and wfβ: "packet_independent_β_unknown β"
    shows "(β, α),p transform_remove_unknowns_generic (β, α) rs, s α t  (β, α),p rs, s α t"
      and "simple_ruleset (transform_remove_unknowns_generic (β, α) rs)"
      and " r  set rs. ¬ has_disc disc (get_match r) 
             r  set (transform_remove_unknowns_generic (β, α) rs). ¬ has_disc disc (get_match r)"
      and " r  set (transform_remove_unknowns_generic (β, α) rs). ¬ has_unknowns β (get_match r)"
      (*may return MatchNot MatchAny*)
      and " r  set rs. normalized_n_primitive disc_sel f (get_match r) 
             r  set (transform_remove_unknowns_generic (β, α) rs). normalized_n_primitive disc_sel f (get_match r)"
      and " r  set rs. ¬ has_disc_negated disc neg (get_match r) 
             r  set (transform_remove_unknowns_generic (β, α) rs). ¬ has_disc_negated disc neg (get_match r)"
  proof -
    let ="(β, α)"
    let ?fw="λrs. approximating_bigstep_fun  p rs s"

    show simplers1: "simple_ruleset (transform_remove_unknowns_generic  rs)"
      unfolding transform_remove_unknowns_generic_def
      using simplers optimize_matches_a_simple_ruleset by blast

    show ",p transform_remove_unknowns_generic  rs, s α t  ,p rs, s α t"
      unfolding approximating_semantics_iff_fun_good_ruleset[OF simple_imp_good_ruleset[OF simplers1]]
      unfolding approximating_semantics_iff_fun_good_ruleset[OF simple_imp_good_ruleset[OF simplers]]
      unfolding transform_remove_unknowns_generic_def
      using optimize_matches_a_simplers[OF simplers] remove_unknowns_generic by metis

      from remove_unknowns_generic_not_has_disc show
        " r  set rs. ¬ has_disc disc (get_match r) 
             r  set (transform_remove_unknowns_generic  rs). ¬ has_disc disc (get_match r)"
      unfolding transform_remove_unknowns_generic_def
      by(intro optimize_matches_a_preserves) blast

      from remove_unknowns_generic_normalized_n_primitive show
        " r  set rs. normalized_n_primitive disc_sel f (get_match r) 
            r  set (transform_remove_unknowns_generic  rs). normalized_n_primitive disc_sel f (get_match r)"
      unfolding transform_remove_unknowns_generic_def
      by(intro optimize_matches_a_preserves) blast

    show " r  set (transform_remove_unknowns_generic  rs). ¬ has_unknowns β (get_match r)"
      unfolding transform_remove_unknowns_generic_def
      apply(rule optimize_matches_a_preserves)
      apply(rule remove_unknowns_generic_specification[OF _ packet_independent_α wfβ])
      using simplers by(simp add: simple_ruleset_def)

    from remove_unknowns_generic_not_has_disc_negated show
      " r  set rs. ¬ has_disc_negated disc neg (get_match r) 
          r  set (transform_remove_unknowns_generic  rs). ¬ has_disc_negated disc neg (get_match r)"
      unfolding transform_remove_unknowns_generic_def
      by(rule optimize_matches_a_preserves) blast
qed
thm transform_remove_unknowns_generic[OF _ _ _ packet_independent_β_unknown_common_matcher]


corollary transform_remove_unknowns_upper: defines "upper  optimize_matches_a upper_closure_matchexpr"
   assumes simplers: "simple_ruleset rs"
    shows "(common_matcher, in_doubt_allow),p upper rs, s α t  (common_matcher, in_doubt_allow),p rs, s α t"
      and "simple_ruleset (upper rs)"
      and " r  set rs. ¬ has_disc disc (get_match r) 
             r  set (upper rs). ¬ has_disc disc (get_match r)"
      and " r  set (upper rs). ¬ has_disc is_Extra (get_match r)"
      and " r  set rs. normalized_n_primitive disc_sel f (get_match r) 
             r  set (upper rs). normalized_n_primitive disc_sel f (get_match r)"
      and " r  set rs. ¬ has_disc_negated disc neg (get_match r) 
             r  set (upper rs). ¬ has_disc_negated disc neg (get_match r)"
proof -
  from simplers have upper: "upper rs = transform_remove_unknowns_generic (common_matcher, in_doubt_allow) rs"
    apply(simp add: transform_remove_unknowns_generic_def upper_def)
    apply(erule optimize_matches_a_simple_ruleset_eq)
    by (simp add: upper_closure_matchexpr_generic)

  note * = transform_remove_unknowns_generic[OF 
      simplers wf_in_doubt_allow packet_independent_unknown_match_tacs(1) packet_independent_β_unknown_common_matcher,
      simplified upper_closure_matchexpr_generic]

    from *(1)[where p = p]
    show "(common_matcher, in_doubt_allow),p upper rs, s α t  (common_matcher, in_doubt_allow),p rs, s α t"
      by(subst upper)
    from *(2) show "simple_ruleset (upper rs)" by(subst upper)
    from *(3) show " r  set rs. ¬ has_disc disc (get_match r) 
             r  set (upper rs). ¬ has_disc disc (get_match r)"
      by(subst upper) fast
    from *(4) show " r  set (upper rs). ¬ has_disc is_Extra (get_match r)" 
      apply(subst upper)
      using has_unknowns_common_matcher by auto
    from *(5) show " r  set rs. normalized_n_primitive disc_sel f (get_match r) 
             r  set (upper rs). normalized_n_primitive disc_sel f (get_match r)"
      apply(subst upper)
      using packet_independent_unknown_match_tacs(1) simplers
        transform_remove_unknowns_generic(5)[OF _ _ _ packet_independent_β_unknown_common_matcher] wf_in_doubt_allow
      by blast
    from *(6) show " r  set rs. ¬ has_disc_negated disc neg (get_match r) 
             r  set (upper rs). ¬ has_disc_negated disc neg (get_match r)"
      by(subst upper) fast
qed


(*copy&paste from transform_remove_unknowns_upper*)
corollary transform_remove_unknowns_lower: defines "lower  optimize_matches_a lower_closure_matchexpr"
   assumes simplers: "simple_ruleset rs"
    shows "(common_matcher, in_doubt_deny),p lower rs, s α t  (common_matcher, in_doubt_deny),p rs, s α t"
      and "simple_ruleset (lower rs)"
      and " r  set rs. ¬ has_disc disc (get_match r) 
             r  set (lower rs). ¬ has_disc disc (get_match r)"
      and " r  set (lower rs). ¬ has_disc is_Extra (get_match r)"
      and " r  set rs. normalized_n_primitive disc_sel f (get_match r) 
             r  set (lower rs). normalized_n_primitive disc_sel f (get_match r)"
      and " r  set rs. ¬ has_disc_negated disc neg (get_match r) 
             r  set (lower rs). ¬ has_disc_negated disc neg (get_match r)"
proof -
  from simplers have lower: "lower rs = transform_remove_unknowns_generic (common_matcher, in_doubt_deny) rs"
    apply(simp add: transform_remove_unknowns_generic_def lower_def)
    apply(erule optimize_matches_a_simple_ruleset_eq)
    by (simp add: lower_closure_matchexpr_generic)

  note * = transform_remove_unknowns_generic[OF 
      simplers wf_in_doubt_deny packet_independent_unknown_match_tacs(2) packet_independent_β_unknown_common_matcher,
      simplified lower_closure_matchexpr_generic]

    from *(1)[where p = p]
    show "(common_matcher, in_doubt_deny),p lower rs, s α t  (common_matcher, in_doubt_deny),p rs, s α t" 
      by(subst lower)
    from *(2) show "simple_ruleset (lower rs)" by(subst lower)
    from *(3) show " r  set rs. ¬ has_disc disc (get_match r) 
             r  set (lower rs). ¬ has_disc disc (get_match r)"
      by(subst lower) fast
    from *(4) show " r  set (lower rs). ¬ has_disc is_Extra (get_match r)" 
      apply(subst lower)
      using has_unknowns_common_matcher by auto
    from *(5) show " r  set rs. normalized_n_primitive disc_sel f (get_match r) 
             r  set (lower rs). normalized_n_primitive disc_sel f (get_match r)"
      apply(subst lower)
      using packet_independent_unknown_match_tacs(1) simplers
        transform_remove_unknowns_generic(5)[OF _ _ _ packet_independent_β_unknown_common_matcher] wf_in_doubt_deny
      by blast
    from *(6) show " r  set rs. ¬ has_disc_negated disc neg (get_match r) 
             r  set (lower rs). ¬ has_disc_negated disc neg (get_match r)"
      by(subst lower) fast
qed



subsection‹Normalizing and Transforming Primitives›

text‹Rewrite the primitives IPs and Ports such that can be used by the simple firewall.›
definition transform_normalize_primitives :: "'i::len common_primitive rule list  'i common_primitive rule list" where 
    "transform_normalize_primitives =
      optimize_matches_option compress_normalize_besteffort  ― ‹normalizes protocols, needs to go last›
      normalize_rules normalize_dst_ips 
      normalize_rules normalize_src_ips 
      normalize_rules normalize_dst_ports  ― ‹may introduce new matches on protocols›
      normalize_rules normalize_src_ports  ― ‹may introduce new matches in protocols›
      normalize_rules rewrite_MultiportPorts ― ‹introduces Src_Ports› and Dst_Ports› matches›"


 thm normalize_primitive_extract_preserves_unrelated_normalized_n_primitive
 lemma normalize_rules_preserves_unrelated_normalized_n_primitive:
   assumes " r  set rs. normalized_nnf_match (get_match r)  normalized_n_primitive (disc2, sel2) P (get_match r)" 
       and "wf_disc_sel (disc1, sel1) C"
       and "a. ¬ disc2 (C a)"
    shows "r  set (normalize_rules (normalize_primitive_extract (disc1, sel1) C f) rs).
              normalized_nnf_match (get_match r)  normalized_n_primitive (disc2, sel2) P (get_match r)"
    thm normalize_rules_preserves[where P="λm. normalized_nnf_match m  normalized_n_primitive  (disc2, sel2) P m"
        and f="normalize_primitive_extract (disc1, sel1) C f"]
    apply(rule normalize_rules_preserves[where P="λm. normalized_nnf_match m  normalized_n_primitive  (disc2, sel2) P m"
        and f="normalize_primitive_extract (disc1, sel1) C f"])
     using assms(1) apply(simp)
    apply(safe)
     using normalize_primitive_extract_preserves_nnf_normalized[OF _ assms(2)] apply fast
    using normalize_primitive_extract_preserves_unrelated_normalized_n_primitive[OF _ _ assms(2) assms(3)] by blast


  lemma normalize_rules_normalized_n_primitive:
   assumes " r  set rs. normalized_nnf_match (get_match r)"
       and "m. normalized_nnf_match m 
             (m'  set (normalize_primitive_extract (disc, sel) C f m). normalized_n_primitive (disc, sel) P m')"
    shows "r  set (normalize_rules (normalize_primitive_extract (disc, sel) C f) rs).
           normalized_n_primitive (disc, sel) P (get_match r)"
    apply(rule normalize_rules_property[where P=normalized_nnf_match and f="normalize_primitive_extract (disc, sel) C f"])
     using assms(1) apply simp
    using assms(2) by simp

  lemma optimize_matches_option_compress_normalize_besteffort_preserves_unrelated_normalized_n_primitive:
   assumes " r  set rs. normalized_nnf_match (get_match r)  normalized_n_primitive (disc2, sel2) P (get_match r)" 
       and "a. ¬ disc2 (IIface a)" and "a. ¬ disc2 (OIface a)" and "a. ¬ disc2 (Prot a)"
    shows "r  set (optimize_matches_option compress_normalize_besteffort rs).
            normalized_nnf_match (get_match r)  normalized_n_primitive (disc2, sel2) P (get_match r)"
    thm optimize_matches_option_preserves
    apply(rule optimize_matches_option_preserves[where P="λm. normalized_nnf_match m  normalized_n_primitive  (disc2, sel2) P m"
        and f="compress_normalize_besteffort"])
    apply(rule compress_normalize_besteffort_preserves_normalized_n_primitive)
         apply(simp_all add: assms)
    done

(*We write (∀a. ¬ disc (Src_Ports a)) to say that, basically, disc is not the function is_Src_Ports.
  But hey, equality on functions, ....*)
theorem transform_normalize_primitives:
  ― ‹all discriminators which will not be normalized remain unchanged›
  defines "unchanged disc  (a. ¬ disc (Src_Ports a))  (a. ¬ disc (Dst_Ports a)) 
                             (a. ¬ disc (Src a))  (a. ¬ disc (Dst a))"
      ― ‹also holds for these discriminators, but not for @{const Prot}, which might be changed›
      and "changeddisc disc  ((a. ¬ disc (IIface a))  disc = is_Iiface) 
                               ((a. ¬ disc (OIface a))  disc = is_Oiface)"
                               (*port normalization may introduce new matches on protocols*)
  assumes simplers: "simple_ruleset (rs :: 'i::len common_primitive rule list)"
      and wfα: "wf_unknown_match_tac α"
      and normalized: " r  set rs. normalized_nnf_match (get_match r)"
  shows "(common_matcher, α),p transform_normalize_primitives rs, s α t  (common_matcher, α),p rs, s α t"
    and "simple_ruleset (transform_normalize_primitives rs)"
    and "unchanged disc1  changeddisc disc1  a. ¬ disc1 (Prot a) 
            r  set rs. ¬ has_disc disc1 (get_match r) 
               r  set (transform_normalize_primitives rs). ¬ has_disc disc1 (get_match r)"
    and " r  set (transform_normalize_primitives rs). normalized_nnf_match (get_match r)"
    and " r  set (transform_normalize_primitives rs).
          normalized_src_ports (get_match r)  normalized_dst_ports (get_match r) 
          normalized_src_ips (get_match r)  normalized_dst_ips (get_match r) 
          ¬ has_disc is_MultiportPorts (get_match r)"
    and "unchanged disc2  (a. ¬ disc2 (IIface a))  (a. ¬ disc2 (OIface a))  (a. ¬ disc2 (Prot a)) 
          r  set rs. normalized_n_primitive (disc2, sel2) f (get_match r) 
             r  set (transform_normalize_primitives rs). normalized_n_primitive (disc2, sel2) f (get_match r)"
    ― ‹For disc3, we do not allow ports and ips, because these are changed.
       Here is the complicated part:
       (It is only complicated if, basically disc3 is @{const is_Prot})
       In addition, either it must not be protocol or (complicated case) 
       there must be no negated port matches 
       in the ruleset. Note that negated @{const Src_Ports} or @{const Dst_Ports} can also be
       introduced by rewriting @{const MultiportPorts}
    and "unchanged disc3  changeddisc disc3 
        (a. ¬ disc3 (Prot a)) 
        (disc3 = is_Prot  ( r  set rs.
          ¬ has_disc_negated is_Src_Ports False (get_match r) 
          ¬ has_disc_negated is_Dst_Ports False (get_match r) 
          ¬ has_disc is_MultiportPorts (get_match r))) 
          r  set rs. ¬ has_disc_negated disc3 False (get_match r) 
             r  set (transform_normalize_primitives rs). ¬ has_disc_negated disc3 False (get_match r)"
  proof -
    let ="(common_matcher, α)"
    let ?fw="λrs. approximating_bigstep_fun  p rs s"

    show simplers_t: "simple_ruleset (transform_normalize_primitives rs)"
      unfolding transform_normalize_primitives_def
      by(simp add: simple_ruleset_normalize_rules simplers optimize_matches_option_simple_ruleset)

    let ?rs0="normalize_rules rewrite_MultiportPorts rs"
    let ?rs1="normalize_rules normalize_src_ports ?rs0"
    let ?rs2="normalize_rules normalize_dst_ports ?rs1"
    let ?rs3="normalize_rules normalize_src_ips ?rs2"
    let ?rs4="normalize_rules normalize_dst_ips ?rs3"
    let ?rs5="optimize_matches_option compress_normalize_besteffort ?rs4"

    have normalized_rs0: "r  set ?rs0. normalized_nnf_match (get_match r)"
      apply(intro normalize_rules_preserves[OF normalized])
      apply(simp add: rewrite_MultiportPorts_def)
      using normalized_nnf_match_normalize_match by blast
    from normalize_src_ports_nnf have normalized_rs1: "r  set ?rs1. normalized_nnf_match (get_match r)"
      apply(intro normalize_rules_preserves[OF normalized_rs0])
      using normalize_dst_ports_nnf by blast
    from normalize_dst_ports_nnf have normalized_rs2: "r  set ?rs2. normalized_nnf_match (get_match r)"
      apply(intro normalize_rules_preserves[OF normalized_rs1])
      by blast
    from normalize_rules_primitive_extract_preserves_nnf_normalized[OF this wf_disc_sel_common_primitive(3)]
         normalize_src_ips_def
    have normalized_rs3: "r  set ?rs3. normalized_nnf_match (get_match r)" by metis
    from normalize_rules_primitive_extract_preserves_nnf_normalized[OF this wf_disc_sel_common_primitive(4)]
         normalize_dst_ips_def
    have normalized_rs4: "r  set ?rs4. normalized_nnf_match (get_match r)" by metis
    have normalized_rs5: "r  set ?rs5. normalized_nnf_match (get_match r)"
      apply(intro optimize_matches_option_preserves)
      apply(erule compress_normalize_besteffort_nnf[rotated])
      by(simp add: normalized_rs4)
    thus " r  set (transform_normalize_primitives rs). normalized_nnf_match (get_match r)"
      unfolding transform_normalize_primitives_def by simp

    (*add this as generic simp rule somewhere? But simplifier loops? what to do? cong_rule?*)
    have local_simp: "rs1 rs2. approximating_bigstep_fun  p rs1 s = approximating_bigstep_fun  p rs2 s 
      (approximating_bigstep_fun  p rs1 s = t) = (approximating_bigstep_fun  p rs2 s = t)" by simp

    have opt_compress_rule:
      "approximating_bigstep_fun (common_matcher, α) p (optimize_matches_option compress_normalize_besteffort rs1) s =
           approximating_bigstep_fun (common_matcher, α) p rs2 s"
    if rs1_n: "r  set rs1. normalized_nnf_match (get_match r)" 
    and rs1rs2: "approximating_bigstep_fun (common_matcher, α) p rs1 s =
           approximating_bigstep_fun (common_matcher, α) p rs2 s" for rs1 rs2
     apply(subst optimize_matches_option_generic[where P="λ m a. normalized_nnf_match m"])
       apply(simp_all add: normalized
                  compress_normalize_besteffort_Some[OF primitive_matcher_generic_common_matcher]
                  compress_normalize_besteffort_None[OF primitive_matcher_generic_common_matcher]
                  rs1_n)
     using rs1rs2 by simp

    show ",p transform_normalize_primitives rs, s α t  ,p rs, s α t"
     unfolding approximating_semantics_iff_fun_good_ruleset[OF simple_imp_good_ruleset[OF simplers_t]]
     unfolding approximating_semantics_iff_fun_good_ruleset[OF simple_imp_good_ruleset[OF simplers]]
     unfolding transform_normalize_primitives_def
     apply(simp)
     apply(subst local_simp, simp_all)
     apply(rule opt_compress_rule[OF normalized_rs4])
     apply(subst normalize_rules_match_list_semantics_3[of normalized_nnf_match])
        using normalize_dst_ips[where p = p] apply(simp; fail)
       using simplers simple_ruleset_normalize_rules apply blast
      using normalized_rs3 apply(simp; fail)
     apply(subst normalize_rules_match_list_semantics_3[of normalized_nnf_match])
        using normalize_src_ips[where p = p] apply(simp; fail)
       using simplers simple_ruleset_normalize_rules apply blast
      using normalized_rs2 apply(simp; fail)
     apply(subst normalize_rules_match_list_semantics_3[of normalized_nnf_match])
        using normalize_dst_ports[OF primitive_matcher_generic_common_matcher,where p = p] apply(simp; fail)
       using simplers simple_ruleset_normalize_rules apply blast
      using normalized_rs1 apply(simp; fail)
     apply(subst normalize_rules_match_list_semantics_3[of normalized_nnf_match])
        using normalize_src_ports[OF primitive_matcher_generic_common_matcher, where p = p] apply(simp; fail)
       using simplers simple_ruleset_normalize_rules apply blast
      using normalized_rs0 apply(simp; fail)
     apply(subst normalize_rules_match_list_semantics_3[of normalized_nnf_match])
        using rewrite_MultiportPorts[OF primitive_matcher_generic_common_matcher, where p = p] apply(simp; fail)
       using simplers apply blast
      using normalized apply(simp; fail)
     ..

    (*naming: does not "normalize" but eliminate all multiportPorts!*)
    from rewrite_MultiportPorts_removes_MultiportsPorts
      normalize_rules_property[OF normalized, where f=rewrite_MultiportPorts and Q="λm. ¬ has_disc is_MultiportPorts m"]
    have rewrite_MultiportPorts_normalizes_Multiports:
      "r  set ?rs0. ¬ has_disc is_MultiportPorts (get_match r)"
      by blast
    from normalize_src_ports_normalized_n_primitive
    have normalized_src_ports: "r  set ?rs1. normalized_src_ports (get_match r)"
    apply(intro normalize_rules_property[OF normalized_rs0, where f=normalize_src_ports and Q=normalized_src_ports])
      by blast
    from normalize_dst_ports_normalized_n_primitive
         normalize_rules_property[OF normalized_rs1, where f=normalize_dst_ports and Q=normalized_dst_ports]
    have normalized_dst_ports: "r  set ?rs2.  normalized_dst_ports (get_match r)" by fast
    from normalize_src_ips_normalized_n_primitive
         normalize_rules_property[OF normalized_rs2, where f=normalize_src_ips and Q=normalized_src_ips]
    have normalized_src_ips: "r  set ?rs3.  normalized_src_ips (get_match r)" by fast
    from normalize_dst_ips_normalized_n_primitive
         normalize_rules_property[OF normalized_rs3, where f=normalize_dst_ips and Q=normalized_dst_ips]
         normalized_rs4
    have normalized_dst_ips_rs4: "r  set ?rs4. normalized_nnf_match (get_match r)  normalized_dst_ips (get_match r)" by fast
    with optimize_matches_option_compress_normalize_besteffort_preserves_unrelated_normalized_n_primitive[
          of _ is_Dst dst_sel normalized_cidr_ip
          , folded normalized_dst_ips_def2]
    have normalized_dst_rs5: "r  set ?rs5. normalized_dst_ips (get_match r)" by fastforce

    have normalize_dst_ports_preserves_normalized_src_ports:
      "m'  set (normalize_dst_ports m)  normalized_nnf_match m 
        normalized_src_ports m  normalized_src_ports m'" for m m' :: " 'i common_primitive match_expr"
      unfolding normalized_src_ports_def2
      apply(rule normalize_ports_generic_preserves_normalized_n_primitive[OF _ wf_disc_sel_common_primitive(2)])
           apply(simp_all)
      by (simp add: normalize_dst_ports_def normalize_ports_generic_def normalize_positive_dst_ports_def rewrite_negated_dst_ports_def)


    from normalize_rules_preserves_unrelated_normalized_n_primitive[of
         _ is_MultiportPorts multiportports_sel "λ_. False"]
    have preserve_normalized_multiport_ports: " 
      r set rs. normalized_nnf_match (get_match r) 
      r set rs. ¬ has_disc is_MultiportPorts (get_match r) 
      wf_disc_sel (disc, sel) C 
      a. ¬ is_MultiportPorts (C a) 
      r set (normalize_rules (normalize_primitive_extract (disc, sel) C f) rs).
        ¬ has_disc is_MultiportPorts (get_match r)"
      for f :: "'c negation_type list  'c list" and rs disc sel
      and C :: "'c  'i::len common_primitive"
      using normalized_n_primitive_false_eq_notdisc
      by blast
    (*TODO: push through*)
    have normalized_multiportports_rs1: "r  set ?rs1. ¬ has_disc is_MultiportPorts (get_match r)"
      apply(rule normalize_rules_property[where P="λm. normalized_nnf_match m  ¬ has_disc is_MultiportPorts m"])
       using normalized_rs0 rewrite_MultiportPorts_normalizes_Multiports apply blast
      apply(intro allI impI ballI)
      apply(rule normalize_src_ports_preserves_normalized_not_has_disc)
         by(simp_all)
    have normalized_multiportports_rs2: "r  set ?rs2. ¬ has_disc is_MultiportPorts (get_match r)"
      apply(rule normalize_rules_property[where P="λm. normalized_nnf_match m  ¬ has_disc is_MultiportPorts m"])
       using normalized_rs1 normalized_multiportports_rs1 apply blast
      apply(intro allI impI ballI)
      apply(rule normalize_dst_ports_preserves_normalized_not_has_disc)
         by(simp_all)
    from preserve_normalized_multiport_ports[OF normalized_rs2 normalized_multiportports_rs2 wf_disc_sel_common_primitive(3),
         where f2=ipt_iprange_compress, folded normalize_src_ips_def]
    have normalized_multiportports_rs3: "r  set ?rs3. ¬ has_disc is_MultiportPorts (get_match r)" by simp
    from preserve_normalized_multiport_ports[OF normalized_rs3 normalized_multiportports_rs3 wf_disc_sel_common_primitive(4),
         where f2=ipt_iprange_compress, folded normalize_dst_ips_def]
         normalized_rs4
    have normalized_multiportports_rs4: "r  set ?rs4. normalized_nnf_match (get_match r)  ¬ has_disc is_MultiportPorts (get_match r)" by simp
    with optimize_matches_option_compress_normalize_besteffort_preserves_unrelated_normalized_n_primitive[
          of _ is_MultiportPorts multiportports_sel "λ_. False"
          , simplified]
    have normalized_multiportports_rs5: "r  set ?rs5. ¬ has_disc is_MultiportPorts (get_match r)"
      using normalized_n_primitive_false_eq_notdisc by fastforce

    from normalize_rules_preserves_unrelated_normalized_n_primitive[of _ is_Src_Ports src_ports_sel "(λps. case ps of L4Ports _ pts  length pts  1)",
         folded normalized_src_ports_def2]
    have preserve_normalized_src_ports: " 
      r set rs. normalized_nnf_match (get_match r) 
      r set rs. normalized_src_ports (get_match r) 
      wf_disc_sel (disc, sel) C 
      a. ¬ is_Src_Ports (C a) 
      r set (normalize_rules (normalize_primitive_extract (disc, sel) C f) rs). normalized_src_ports (get_match r)"
      for f :: "'c negation_type list  'c list" and rs disc sel and C :: "'c  'i::len common_primitive"
      by blast
    have normalized_src_ports_rs2: "r  set ?rs2.  normalized_src_ports (get_match r)"
      apply(rule normalize_rules_property[where P="λm. normalized_nnf_match m  normalized_src_ports m"])
       using normalized_rs1 normalized_src_ports apply blast
      apply(clarify)
      using normalize_dst_ports_preserves_normalized_src_ports by blast
    from preserve_normalized_src_ports[OF normalized_rs2 normalized_src_ports_rs2 wf_disc_sel_common_primitive(3),
         where f3=ipt_iprange_compress, folded normalize_src_ips_def]
    have normalized_src_ports_rs3: "r  set ?rs3.  normalized_src_ports (get_match r)" by simp
    from preserve_normalized_src_ports[OF normalized_rs3 normalized_src_ports_rs3 wf_disc_sel_common_primitive(4),
         where f3=ipt_iprange_compress, folded normalize_dst_ips_def]
         normalized_rs4
    have normalized_src_ports_rs4: "r  set ?rs4. normalized_nnf_match (get_match r)  normalized_src_ports (get_match r)" by simp
    with optimize_matches_option_compress_normalize_besteffort_preserves_unrelated_normalized_n_primitive[
          of _ is_Src_Ports src_ports_sel "(λps. case ps of L4Ports _ pts  length pts  1)"
          , folded normalized_src_ports_def2]
    have normalized_src_ports_rs5: "r  set ?rs5. normalized_src_ports (get_match r)" by fastforce

    from normalize_rules_preserves_unrelated_normalized_n_primitive[of _ is_Dst_Ports dst_ports_sel "(λps. case ps of L4Ports _ pts  length pts  1)",
         folded normalized_dst_ports_def2]
    have preserve_normalized_dst_ports: "rs disc sel C f. 
      rset rs. normalized_nnf_match (get_match r) 
      rset rs. normalized_dst_ports (get_match r) 
      wf_disc_sel (disc, sel) C 
      a. ¬ is_Dst_Ports (C a) 
      r set (normalize_rules (normalize_primitive_extract (disc, sel) C f) rs). normalized_dst_ports (get_match r)"
      by blast
    from preserve_normalized_dst_ports[OF normalized_rs2 normalized_dst_ports wf_disc_sel_common_primitive(3),
         where f3=ipt_iprange_compress, folded normalize_src_ips_def]
    have normalized_dst_ports_rs3: "r  set ?rs3.  normalized_dst_ports (get_match r)" by force
    from preserve_normalized_dst_ports[OF normalized_rs3 normalized_dst_ports_rs3 wf_disc_sel_common_primitive(4),
         where f3=ipt_iprange_compress, folded normalize_dst_ips_def]
         normalized_rs4
    have normalized_dst_ports_rs4: "r  set ?rs4. normalized_nnf_match (get_match r)  normalized_dst_ports (get_match r)" by force
    with optimize_matches_option_compress_normalize_besteffort_preserves_unrelated_normalized_n_primitive[
          of _ is_Dst_Ports dst_ports_sel "(λps. case ps of L4Ports _ pts  length pts  1)"
          , folded normalized_dst_ports_def2]
    have normalized_dst_ports_rs5: "r  set ?rs5. normalized_dst_ports (get_match r)" by fastforce

    from normalize_rules_preserves_unrelated_normalized_n_primitive[of ?rs3 is_Src src_sel normalized_cidr_ip,
         OF _ wf_disc_sel_common_primitive(4),
         where f=ipt_iprange_compress, folded normalize_dst_ips_def normalized_src_ips_def2]
         normalized_rs3 normalized_src_ips
    have normalized_src_rs4: "r  set ?rs4. normalized_nnf_match (get_match r)  normalized_src_ips (get_match r)" by force
    with optimize_matches_option_compress_normalize_besteffort_preserves_unrelated_normalized_n_primitive[
          of _ is_Src src_sel normalized_cidr_ip
          , folded normalized_src_ips_def2]
    have normalized_src_rs5: "r  set ?rs5. normalized_src_ips (get_match r)"
       by fastforce

    from normalized_multiportports_rs5 normalized_src_ports_rs5
         normalized_dst_ports_rs5 normalized_src_rs5 normalized_dst_rs5
    show " r  set (transform_normalize_primitives rs).
          normalized_src_ports (get_match r)  normalized_dst_ports (get_match r) 
          normalized_src_ips (get_match r)  normalized_dst_ips (get_match r) 
          ¬ has_disc is_MultiportPorts (get_match r)"
      unfolding transform_normalize_primitives_def by simp
   

   show  "unchanged disc2  (a. ¬ disc2 (IIface a))  (a. ¬ disc2 (OIface a))  (a. ¬ disc2 (Prot a)) 
           r  set rs. normalized_n_primitive (disc2, sel2) f (get_match r) 
             r  set (transform_normalize_primitives rs). normalized_n_primitive  (disc2, sel2) f (get_match r)"
   unfolding unchanged_def
   proof(elim conjE)
     assume "r set rs. normalized_n_primitive  (disc2, sel2) f (get_match r)"
     with normalized have a':
      "r set rs. normalized_nnf_match (get_match r)  normalized_n_primitive (disc2, sel2) f (get_match r)" by blast

     assume a_Src_Ports: "a. ¬ disc2 (Src_Ports a)"
     assume a_Dst_Ports: "a. ¬ disc2 (Dst_Ports a)"
     assume a_Src: "a. ¬ disc2 (Src a)"
     assume a_Dst: "a. ¬ disc2 (Dst a)"
     assume a_IIface: "(a. ¬ disc2 (IIface a))"
     assume a_OIface: "(a. ¬ disc2 (OIface a))"
     assume a_Prot: "(a. ¬ disc2 (Prot a))"


     have normalized_n_primitive_rs0:
     "rset ?rs0. normalized_n_primitive (disc2, sel2) f (get_match r)"
      apply(intro normalize_rules_property[where P="λm. normalized_nnf_match m  normalized_n_primitive (disc2, sel2) f m"])
       using a' apply blast
      using rewrite_MultiportPorts_preserves_normalized_n_primitive[OF _ a_Src_Ports a_Dst_Ports] by blast
     have normalized_n_primitive_rs1:
     "rset ?rs1. normalized_n_primitive (disc2, sel2) f (get_match r)" (*by blast*)
      apply(rule normalize_rules_property[where P="λm. normalized_nnf_match m  normalized_n_primitive (disc2, sel2) f m"])
       using normalized_n_primitive_rs0 normalized_rs0 apply blast
      using normalize_src_ports_preserves_normalized_n_primitive[OF _ a_Src_Ports] a_Prot by blast
     have "rset ?rs2. normalized_n_primitive (disc2, sel2) f (get_match r)"
      apply(rule normalize_rules_property[where P="λm. normalized_nnf_match m  normalized_n_primitive (disc2, sel2) f m"])
       using normalized_n_primitive_rs1 normalized_rs1 apply blast
      using normalize_dst_ports_preserves_normalized_n_primitive[OF _ a_Dst_Ports] a_Prot by blast
     with normalized_rs2 normalize_rules_preserves_unrelated_normalized_n_primitive[OF _ wf_disc_sel_common_primitive(3) a_Src,
       of ?rs2 sel2 f ipt_iprange_compress,
       folded normalize_src_ips_def]
     have "rset ?rs3. normalized_n_primitive (disc2, sel2) f (get_match r)" by blast
     with normalized_rs3 normalize_rules_preserves_unrelated_normalized_n_primitive[OF _ wf_disc_sel_common_primitive(4) a_Dst,
       of ?rs3 sel2 f ipt_iprange_compress,
       folded normalize_dst_ips_def]
     have "rset ?rs4. normalized_nnf_match (get_match r)  normalized_n_primitive (disc2, sel2) f (get_match r)" by blast
     hence "rset ?rs5. normalized_nnf_match (get_match r)  normalized_n_primitive (disc2, sel2) f (get_match r)" 
       apply(intro optimize_matches_option_compress_normalize_besteffort_preserves_unrelated_normalized_n_primitive)
          using a_IIface a_OIface a_Prot by simp_all
     thus ?thesis
       unfolding transform_normalize_primitives_def by simp
   qed

   ― ‹Pushing through properties through the ip normalizer›
   { fix m and m' and disc::"('i::len common_primitive  bool)"
         and sel::"('i::len common_primitive  'x)" and C'::" ('x  'i::len common_primitive)"
         and f'::"('x negation_type list  'x list)"
     assume am: "¬ has_disc disc1 m"
        and nm: "normalized_nnf_match m"
        and am': "m'  set (normalize_primitive_extract (disc, sel) C' f' m)"
        and wfdiscsel: "wf_disc_sel (disc,sel) C'"
        and disc_different: "a. ¬ disc1 (C' a)"

        (*from wfdiscsel disc_different have "∀a. ¬ disc1 (C' a)"
          apply(simp add: wf_disc_sel.simps)*)

        from disc_different have af: "spts. (a  Match ` C' ` set (f' spts). ¬ has_disc disc1 a)"
          by(simp)

        obtain as ms where asms: "primitive_extractor (disc, sel) m = (as, ms)" by fastforce

        from am' asms have "m'  (λspt. MatchAnd (Match (C' spt)) ms) ` set (f' as)"
          unfolding normalize_primitive_extract_def by(simp)
        hence goalrule:"spt  set (f' as). ¬ has_disc disc1 (Match (C' spt))  ¬ has_disc disc1 ms  ¬ has_disc disc1 m'" by fastforce

        from am primitive_extractor_correct(4)[OF nm wfdiscsel asms] have 1: "¬ has_disc disc1 ms" by simp
        from af have 2: "spt  set (f' as). ¬ has_disc disc1 (Match (C' spt))" by simp

        from goalrule[OF 2 1] have "¬ has_disc disc1 m'" .
        moreover from nm have "normalized_nnf_match m'" by (metis am' normalize_primitive_extract_preserves_nnf_normalized wfdiscsel)
        ultimately have "¬ has_disc disc1 m'  normalized_nnf_match m'" by simp
   }
   hence x: "disc sel C' f'. wf_disc_sel (disc, sel) C'  a. ¬ disc1 (C' a) 
   m. normalized_nnf_match m  ¬ has_disc disc1 m 
     (m'set (normalize_primitive_extract (disc, sel) C' f' m). normalized_nnf_match m'  ¬ has_disc disc1 m')"
   by blast

   ― ‹Pushing through properties through the ports normalizer›
   from normalize_src_ports_preserves_normalized_not_has_disc normalize_src_ports_nnf have x_src_ports:
    "a. ¬ disc (Src_Ports a)   a. ¬ disc (Prot a)   
       m'  set (normalize_src_ports m) 
            normalized_nnf_match m  ¬ has_disc disc m  ¬ has_disc disc m'  normalized_nnf_match m'"
    for m m' and disc :: "'i common_primitive  bool" by blast
   from normalize_dst_ports_preserves_normalized_not_has_disc normalize_dst_ports_nnf have x_dst_ports:
    "a. ¬ disc (Dst_Ports a)   a. ¬ disc (Prot a)   
       m' set (normalize_dst_ports m) 
          normalized_nnf_match m  ¬ has_disc disc m  ¬ has_disc disc m'  normalized_nnf_match m'"
    for m m' and disc :: "'i common_primitive  bool"   by blast

   { fix rs
     assume "(a. ¬ disc1 (IIface a))  disc1 = is_Iiface"
        and "((a. ¬ disc1 (OIface a))  disc1 = is_Oiface)"
        and "(a. ¬ disc1 (Prot a))"
     hence "mset rs. ¬ has_disc disc1 (get_match m)  normalized_nnf_match (get_match m) 
              mset (optimize_matches_option compress_normalize_besteffort rs).
                  normalized_nnf_match (get_match m)  ¬ has_disc disc1 (get_match m)"
     apply -
     apply(rule optimize_matches_option_preserves)
     apply(elim disjE)
            using compress_normalize_besteffort_hasdisc apply blast
           using compress_normalize_besteffort_nnf compress_normalize_besteffort_not_introduces_Iiface
                 compress_normalize_besteffort_not_introduces_Oiface by blast+
   } note y=this

   have "a. ¬ disc1 (Src_Ports a)  a. ¬ disc1 (Dst_Ports a)  
         a. ¬ disc1 (Src a)  a. ¬ disc1 (Dst a) 
         (a. ¬ disc1 (IIface a))  disc1 = is_Iiface 
         (a. ¬ disc1 (OIface a))  disc1 = is_Oiface  (a. ¬ disc1 (Prot a)) 
          rset rs. ¬ has_disc disc1 (get_match r)  normalized_nnf_match (get_match r) 
     r  set (transform_normalize_primitives rs). normalized_nnf_match (get_match r)  ¬ has_disc disc1 (get_match r)"
   unfolding transform_normalize_primitives_def
   apply(simp)
   apply(rule y)
      apply(simp; fail)
     apply(simp; fail)
    apply(simp; fail)
   apply(rule normalize_rules_preserves)+
        apply(simp; fail)
       subgoal
       apply(intro allI impI conjI ballI)
        apply(rule rewrite_MultiportPorts_preserves_normalized_not_has_disc, simp_all)
       by(simp add: rewrite_MultiportPorts_normalized_nnf_match)
      subgoal
      apply clarify
      apply(rule x_src_ports)
          by simp+
     subgoal
     apply clarify
     by(rule x_dst_ports) simp+
    using x[OF wf_disc_sel_common_primitive(3), of ipt_iprange_compress,folded normalize_src_ips_def] apply blast
   using x[OF wf_disc_sel_common_primitive(4), of ipt_iprange_compress,folded normalize_dst_ips_def] apply blast
   done
   
   thus "unchanged disc1  changeddisc disc1  a. ¬ disc1 (Prot a) 
     r  set rs. ¬ has_disc disc1 (get_match r) 
       r  set (transform_normalize_primitives rs). ¬ has_disc disc1 (get_match r)"
   unfolding unchanged_def changeddisc_def using normalized by blast

   (*copy pasta*)
   { fix m and m' and disc::"('i::len common_primitive  bool)"
         and sel::"('i::len common_primitive  'x)" and C'::" ('x  'i::len common_primitive)"
         and f'::"('x negation_type list  'x list)" and neg
         and disc3
     assume am: "¬ has_disc_negated disc3 neg m"
        and nm: "normalized_nnf_match m"
        and am': "m'  set (normalize_primitive_extract (disc, sel) C' f' m)"
        and wfdiscsel: "wf_disc_sel (disc,sel) C'"
        and disc_different: "a. ¬ disc3 (C' a)"

        from disc_different have af: "spts. (a  Match ` C' ` set (f' spts). ¬ has_disc disc3 a)"
          by(simp)

        obtain as ms where asms: "primitive_extractor (disc, sel) m = (as, ms)" by fastforce

        from am' asms have "m'  (λspt. MatchAnd (Match (C' spt)) ms) ` set (f' as)"
          unfolding normalize_primitive_extract_def by(simp)
        hence goalrule:"spt  set (f' as). ¬ has_disc_negated disc3 neg (Match (C' spt)) 
            ¬ has_disc_negated disc3 neg ms  ¬ has_disc_negated disc3 neg m'" by fastforce

        from am primitive_extractor_correct(6)[OF nm wfdiscsel asms] have 1: "¬ has_disc_negated disc3 neg ms" by simp
        from af have 2: "spt  set (f' as). ¬ has_disc_negated disc3 neg (Match (C' spt))" by simp

        from goalrule[OF 2 1] have "¬ has_disc_negated disc3 neg m'" .
        moreover from nm have "normalized_nnf_match m'" by (metis am' normalize_primitive_extract_preserves_nnf_normalized wfdiscsel)
        ultimately have "¬ has_disc_negated disc3 neg m'  normalized_nnf_match m'" by simp
   }
   note x_generic=this
   hence x: "wf_disc_sel (disc, sel) C'  a. ¬ disc3 (C' a) 
   m. normalized_nnf_match m  ¬ has_disc_negated disc3 False m 
    (m'  set (normalize_primitive_extract (disc, sel) C' f' m).
            normalized_nnf_match m'  ¬ has_disc_negated disc3 False m')"
   for disc :: "'i common_primitive  bool" and sel and C' :: "'c  'i common_primitive" and f' and disc3
   by blast

   ― ‹Pushing through properties through the ports normalizer›
   from normalize_src_ports_preserves_normalized_not_has_disc_negated normalize_src_ports_nnf have x_src_ports:
    "a. ¬ disc (Src_Ports a)  (a. ¬ disc (Prot a))  ¬ has_disc_negated is_Src_Ports False m   
       m'  set (normalize_src_ports m) 
         normalized_nnf_match m  ¬ has_disc_negated disc False m 
            ¬ has_disc_negated disc False m'  normalized_nnf_match m'"
    for m m' and disc :: "'i common_primitive  bool" by blast

   from normalize_dst_ports_preserves_normalized_not_has_disc_negated normalize_dst_ports_nnf have x_dst_ports:
    "a. ¬ disc (Src_Ports a)  (a. ¬ disc (Prot a))  ¬ has_disc_negated is_Dst_Ports False m   
       m'  set (normalize_dst_ports m) 
         normalized_nnf_match m  ¬ has_disc_negated disc False m 
            ¬ has_disc_negated disc False m'  normalized_nnf_match m'"
    for m m' and disc :: "'i common_primitive  bool" by blast

  (*push arbitrary P m through too. y is then λ_. True [simplified]*)
  { fix rs
    fix P :: "'i common_primitive match_expr  bool"
    assume "(a. ¬ disc3 (IIface a))  disc3 = is_Iiface"
        and "(a. ¬ disc3 (OIface a))  disc3 = is_Oiface"
        and "(a. ¬ disc3 (Prot a))  disc3 = is_Prot"
        and P_prop: "m m'. normalized_nnf_match m  P m  compress_normalize_besteffort m = Some m'  P m'"
     hence
      "rset rs. ¬ has_disc_negated disc3 False (get_match r)  normalized_nnf_match (get_match r)  P (get_match r) 
       rset (optimize_matches_option compress_normalize_besteffort rs).
                normalized_nnf_match (get_match r)  ¬ has_disc_negated disc3 False (get_match r)  P (get_match r)"
     apply -
     thm optimize_matches_option_preserves[where P=
        "λm. normalized_nnf_match m  ¬ has_disc_negated disc3 False m  P m"]
     apply(rule optimize_matches_option_preserves[where P=
        "λm. normalized_nnf_match m  ¬ has_disc_negated disc3 False m  P m"])
     apply(elim disjE)
            using compress_normalize_besteffort_nnf compress_normalize_besteffort_hasdisc_negated apply blast
           using compress_normalize_besteffort_nnf
                 compress_normalize_besteffort_not_introduces_Iiface_negated
                 compress_normalize_besteffort_not_introduces_Oiface_negated
                 compress_normalize_besteffort_not_introduces_Prot_negated by blast+
   } note y_generic=this
  
  note y=y_generic[of "λ_. True", simplified]

  
   have case_disc3_is_not_prot: "a. ¬ disc3 (Src_Ports a)  a. ¬ disc3 (Dst_Ports a)  
         a. ¬ disc3 (Src a)  a. ¬ disc3 (Dst a) 
         (a. ¬ disc3 (IIface a))  disc3 = is_Iiface 
         (a. ¬ disc3 (OIface a))  disc3 = is_Oiface 
         (a. ¬ disc3 (Prot a)) 
          r  set rs. ¬ has_disc_negated disc3 False (get_match r)  normalized_nnf_match (get_match r) 
     r  set (transform_normalize_primitives rs). normalized_nnf_match (get_match r)  ¬ has_disc_negated disc3 False (get_match r)"
   unfolding transform_normalize_primitives_def
   apply(simp)
   apply(rule y)
      apply(simp; fail)
     apply(simp; fail)
    apply(blast)
   apply(rule normalize_rules_preserves)+
        apply(simp; fail)
       subgoal
       apply(intro allI impI conjI ballI)
        apply(rule rewrite_MultiportPorts_preserves_normalized_not_has_disc_negated, simp_all)
       by(simp add: rewrite_MultiportPorts_normalized_nnf_match)
      subgoal
      apply(clarify)
      apply(rule_tac m6=m in x_src_ports)
          by(simp)+
     subgoal
     apply(clarify)
     by(rule x_dst_ports) simp+
    using x[OF wf_disc_sel_common_primitive(3), of disc3 ipt_iprange_compress, folded normalize_src_ips_def] apply blast
   using x[OF wf_disc_sel_common_primitive(4), of disc3 ipt_iprange_compress, folded normalize_dst_ips_def] apply blast
   done

   have case_disc3_is_prot_optimize_matches_option:"rset rs.
         ¬ has_disc_negated is_Prot False (get_match r) 
         normalized_nnf_match (get_match r) 
         ¬ has_disc_negated is_Src_Ports False (get_match r) 
         ¬ has_disc_negated is_Dst_Ports False (get_match r) 
      rset (optimize_matches_option compress_normalize_besteffort rs).
         normalized_nnf_match (get_match r) 
         ¬ has_disc_negated is_Prot False (get_match r) 
         ¬ has_disc_negated is_Src_Ports False (get_match r) 
         ¬ has_disc_negated is_Dst_Ports False (get_match r)"
   if isprot: "disc3 = is_Prot"
   for rs :: "'i common_primitive rule list"
   apply(rule y_generic[where P8="λm. ¬ has_disc_negated is_Src_Ports False m  ¬ has_disc_negated is_Dst_Ports False m", simplified isprot])
       apply simp+
    apply(clarify)
    apply(intro conjI)
     using compress_normalize_besteffort_hasdisc_negated[of is_Src_Ports] apply fastforce
    using compress_normalize_besteffort_hasdisc_negated[of is_Dst_Ports] apply fastforce
   by simp

   (*copy from above, specific version for is_Prot*)
   (*Push through things, but now more complicated because several things could introduce Prots*)
   have case_disc3_is_prot: "disc3 = is_Prot 
   r  set rs. ¬ has_disc_negated disc3 False (get_match r)  normalized_nnf_match (get_match r) 
         ¬ has_disc_negated is_Src_Ports False (get_match r)  ¬ has_disc_negated is_Dst_Ports False (get_match r) &
         ¬ has_disc is_MultiportPorts (get_match r) ― ‹MultiportPorts could be rewritten to negated Src›/Dst› Ports› 
     r  set (transform_normalize_primitives rs). normalized_nnf_match (get_match r)  ¬ has_disc_negated disc3 False (get_match r) 
              ¬ has_disc_negated is_Src_Ports False (get_match r)  ¬ has_disc_negated is_Dst_Ports False (get_match r)"
   unfolding transform_normalize_primitives_def
   apply(simp)
   apply(rule case_disc3_is_prot_optimize_matches_option)
    apply(simp; fail)
   thm normalize_rules_property[
      where P="λm. normalized_nnf_match m  ¬ has_disc_negated disc3 False m"]
   apply(rule normalize_rules_property[
      where P="λm. normalized_nnf_match m 
                   ¬ has_disc_negated disc3 False m 
                   ¬ has_disc_negated is_Src_Ports False m 
                   ¬ has_disc_negated is_Dst_Ports False m"]) (*dst ips*)
    apply(rule normalize_rules_property[
      where P="λm. normalized_nnf_match m 
                   ¬ has_disc_negated disc3 False m 
                   ¬ has_disc_negated is_Src_Ports False m 
                   ¬ has_disc_negated is_Dst_Ports False m"])(*src ips*)
     apply(rule normalize_rules_property[
      where P="λm. normalized_nnf_match m 
                   ¬ has_disc_negated disc3 False m 
                   ¬ has_disc_negated is_Src_Ports False m 
                   ¬ has_disc_negated is_Dst_Ports False m"])(*dst ports*)
      apply(rule normalize_rules_property[
      where P="λm. normalized_nnf_match m 
                   ¬ has_disc_negated disc3 False m 
                   ¬ has_disc_negated is_Src_Ports False m 
                   ¬ has_disc_negated is_Dst_Ports False m"])(*src ports*)
       apply(rule normalize_rules_property[
      where P="λm. normalized_nnf_match m 
                   ¬ has_disc_negated disc3 False m 
                   ¬ has_disc_negated is_Src_Ports False m 
                   ¬ has_disc_negated is_Dst_Ports False m 
                   ¬ has_disc is_MultiportPorts m"]) (*multiports, needs ¬ has_disc is_MultiportPorts m*)
        apply(simp; fail)
       subgoal
       apply(intro allI impI conjI ballI)
          apply(simp add: rewrite_MultiportPorts_normalized_nnf_match; fail)
         apply(rule rewrite_MultiportPorts_preserves_normalized_not_has_disc_negated, simp_all)
         ― ‹Here we need @{term "¬ has_disc is_MultiportPorts m"}
         using rewrite_MultiportPorts_unchanged_if_not_has_disc by fastforce+
      subgoal (*yeah, just need to consider the other cases*)
      apply(clarify)
      apply(frule_tac m6=m in x_src_ports[rotated 2])
          apply(simp_all)
       apply simp
      using normalize_src_ports_preserves_normalized_not_has_disc_negated by blast
     subgoal
     apply(clarify)
     apply(frule_tac m6=m in x_dst_ports[rotated 2])
         apply(simp_all)
      apply simp
     using normalize_dst_ports_preserves_normalized_not_has_disc_negated by blast
    using x[OF wf_disc_sel_common_primitive(3), of disc3 ipt_iprange_compress, folded normalize_src_ips_def]
          x[OF wf_disc_sel_common_primitive(3), of is_Dst_Ports ipt_iprange_compress, folded normalize_src_ips_def]
          x_generic[OF _ _ _ wf_disc_sel_common_primitive(3), of is_Src_Ports False _ _ ipt_iprange_compress, folded normalize_src_ips_def]
          apply (meson common_primitive.disc(45) common_primitive.disc(56) common_primitive.disc(67); fail)
   using x[OF wf_disc_sel_common_primitive(4), of disc3 ipt_iprange_compress, folded normalize_dst_ips_def]
          x[OF wf_disc_sel_common_primitive(4), of is_Src_Ports ipt_iprange_compress, folded normalize_dst_ips_def]
          x_generic[OF _ _ _ wf_disc_sel_common_primitive(4), of is_Dst_Ports False _ _ ipt_iprange_compress, folded normalize_dst_ips_def]
          apply (meson common_primitive.disc(46) common_primitive.disc(57) common_primitive.disc(68); fail)    
   done

   show "unchanged disc3  changeddisc disc3 
    (a. ¬ disc3 (Prot a)) 
        (disc3 = is_Prot  ( r  set rs.
          ¬ has_disc_negated is_Src_Ports False (get_match r) 
          ¬ has_disc_negated is_Dst_Ports False (get_match r) 
          ¬ has_disc is_MultiportPorts (get_match r))) 
          r  set rs. ¬ has_disc_negated disc3 False (get_match r) 
             r  set (transform_normalize_primitives rs). ¬ has_disc_negated disc3 False (get_match r)"
   unfolding unchanged_def changeddisc_def
   apply(elim disjE)
    using normalized case_disc3_is_not_prot apply blast
   using normalized case_disc3_is_prot by blast
qed


theorem iiface_constrain:
  assumes simplers: "simple_ruleset rs"
      and normalized: " r  set rs. normalized_nnf_match (get_match r)"
      and wf_ipassmt: "ipassmt_sanity_nowildcards ipassmt"
      and nospoofing: "ips. ipassmt (Iface (p_iiface p)) = Some ips  p_src p  ipcidr_union_set (set ips)"
  shows "(common_matcher, α),p optimize_matches (iiface_constrain ipassmt) rs, s α t  (common_matcher, α),p rs, s α t"
    and "simple_ruleset (optimize_matches (iiface_constrain ipassmt) rs)"
  proof -
    show simplers_t: "simple_ruleset (optimize_matches (iiface_constrain ipassmt) rs)"
      by (simp add: optimize_matches_simple_ruleset simplers)

    have my_arg_cong: "P Q. P s = Q s  (P s = t)  (Q s = t)" by simp
    
    show "(common_matcher, α),p optimize_matches (iiface_constrain ipassmt) rs, s α t  (common_matcher, α),p rs, s α t"
     unfolding approximating_semantics_iff_fun_good_ruleset[OF simple_imp_good_ruleset[OF simplers_t]]
     unfolding approximating_semantics_iff_fun_good_ruleset[OF simple_imp_good_ruleset[OF simplers]]
     apply(rule my_arg_cong)
     apply(rule optimize_matches_generic[where P="λ m _. normalized_nnf_match m"])
      apply(simp add: normalized)
     apply(rule matches_iiface_constrain)
       apply(simp_all add: wf_ipassmt nospoofing)
     done
qed

text‹In contrast to @{thm iiface_constrain}, this requires  @{const ipassmt_sanity_disjoint} and 
      as much stronger nospoof assumption: This assumption requires that the packet is actually in ipassmt!›
theorem iiface_rewrite:
  assumes simplers: "simple_ruleset rs"
      and normalized: " r  set rs. normalized_nnf_match (get_match r)"
      and wf_ipassmt: "ipassmt_sanity_nowildcards ipassmt"
      and disjoint_ipassmt: "ipassmt_sanity_disjoint ipassmt"
      and nospoofing: "ips. ipassmt (Iface (p_iiface p)) = Some ips  p_src p  ipcidr_union_set (set ips)"
  shows "(common_matcher, α),p optimize_matches (iiface_rewrite ipassmt) rs, s α t  (common_matcher, α),p rs, s α t"
    and "simple_ruleset (optimize_matches (iiface_rewrite ipassmt) rs)"
  proof -
    show simplers_t: "simple_ruleset (optimize_matches (iiface_rewrite ipassmt) rs)"
      by(simp add: simplers optimize_matches_simple_ruleset)

    ― ‹packet must come from a defined interface!›
    from nospoofing have "Iface (p_iiface p)  dom ipassmt" by blast

    have my_arg_cong: "P Q. P s = Q s  (P s = t)  (Q s = t)" by simp
    
    show "(common_matcher, α),p optimize_matches (iiface_rewrite ipassmt) rs, s α t  (common_matcher, α),p rs, s α t"
     unfolding approximating_semantics_iff_fun_good_ruleset[OF simple_imp_good_ruleset[OF simplers_t]]
     unfolding approximating_semantics_iff_fun_good_ruleset[OF simple_imp_good_ruleset[OF simplers]]
     apply(rule my_arg_cong)
     apply(rule optimize_matches_generic[where P="λ m _. normalized_nnf_match m"])
      apply(simp add: normalized)
     apply(rule matches_iiface_rewrite)
        apply(simp_all add: wf_ipassmt nospoofing disjoint_ipassmt)
     done
qed

(* Copy of iiface_rewrite *)
theorem oiface_rewrite:
  assumes simplers: "simple_ruleset rs"
      and normalized: " r  set rs. normalized_nnf_match (get_match r)"
      and wf_ipassmt: "ipassmt_sanity_nowildcards ipassmt"
      and ipassmt_from_rt: "ipassmt = map_of (routing_ipassmt rt)"
      and correct_routing: "correct_routing rt"
      and rtbl_decided: "output_iface (routing_table_semantics rt (p_dst p)) = p_oiface p"
  shows "(common_matcher, α),p optimize_matches (oiface_rewrite ipassmt) rs, s α t  (common_matcher, α),p rs, s α t"
    and "simple_ruleset (optimize_matches (oiface_rewrite ipassmt) rs)"
  proof -
    show simplers_t: "simple_ruleset (optimize_matches (oiface_rewrite ipassmt) rs)"
      using simplers by(fact optimize_matches_simple_ruleset)
    show "(common_matcher, α),p optimize_matches (oiface_rewrite ipassmt) rs, s α t  (common_matcher, α),p rs, s α t"
     unfolding approximating_semantics_iff_fun_good_ruleset[OF simple_imp_good_ruleset[OF simplers_t]]
     unfolding approximating_semantics_iff_fun_good_ruleset[OF simple_imp_good_ruleset[OF simplers]]
     apply(rule arg_cong[where f="λx. x = t"])
     apply(rule optimize_matches_generic[where P="λ m _. normalized_nnf_match m"])
      apply(simp add: normalized ;fail)
     apply(rule matches_oiface_rewrite[OF _ _ _ ipassmt_from_rt]; assumption?)
        apply(simp_all add: wf_ipassmt correct_routing rtbl_decided)
     done
qed


definition upper_closure :: "'i::len common_primitive rule list  'i common_primitive rule list" where
  "upper_closure rs == remdups_rev (transform_optimize_dnf_strict
      (transform_normalize_primitives (transform_optimize_dnf_strict (optimize_matches_a upper_closure_matchexpr rs))))"
definition lower_closure :: "'i::len common_primitive rule list  'i common_primitive rule list" where
  "lower_closure rs == remdups_rev (transform_optimize_dnf_strict
      (transform_normalize_primitives (transform_optimize_dnf_strict (optimize_matches_a lower_closure_matchexpr rs))))"


text‹putting it all together›
lemma transform_upper_closure:
  assumes simplers: "simple_ruleset rs"
  ― ‹semantics are preserved›
  shows "(common_matcher, in_doubt_allow),p upper_closure rs, s α t  (common_matcher, in_doubt_allow),p rs, s α t"
  and "simple_ruleset (upper_closure rs)"
  ― ‹simple, normalized rules without unknowns›
  and " r  set (upper_closure rs). normalized_nnf_match (get_match r) 
                                     normalized_src_ports (get_match r) 
                                     normalized_dst_ports (get_match r) 
                                     normalized_src_ips (get_match r) 
                                     normalized_dst_ips (get_match r) 
                                     ¬ has_disc is_MultiportPorts (get_match r) 
                                     ¬ has_disc is_Extra (get_match r)"
  ― ‹no new primitives are introduced›
  and "a. ¬ disc (Src_Ports a)  a. ¬ disc (Dst_Ports a)  a. ¬ disc (Src a)  a. ¬ disc (Dst a) 
       a. ¬ disc (IIface a)  disc = is_Iiface  a. ¬ disc (OIface a)  disc = is_Oiface 
       a. ¬ disc (Prot a) 
         r  set rs. ¬ has_disc disc (get_match r)   r  set (upper_closure rs). ¬ has_disc disc (get_match r)"
  and "a. ¬ disc (Src_Ports a)  a. ¬ disc (Dst_Ports a)  a. ¬ disc (Src a)  a. ¬ disc (Dst a) 
       a. ¬ disc (IIface a)  disc = is_Iiface  a. ¬ disc (OIface a)  disc = is_Oiface 
       (a. ¬ disc (Prot a)) 
        disc = is_Prot  ― ‹if it is prot, there must not be negated matches on ports›
        ( r  set rs. ¬ has_disc_negated is_Src_Ports False (get_match r) 
                       ¬ has_disc_negated is_Dst_Ports False (get_match r) 
                       ¬ has_disc is_MultiportPorts (get_match r)) 
          r  set rs. ¬ has_disc_negated disc False (get_match r) 
          r  set (upper_closure rs). ¬ has_disc_negated disc False (get_match r)"
  proof -
    let ?rs1="optimize_matches_a upper_closure_matchexpr rs"
    let ?rs2="transform_optimize_dnf_strict ?rs1"
    let ?rs3="transform_normalize_primitives ?rs2"
    let ?rs4="transform_optimize_dnf_strict ?rs3"

    { fix m a
        have "Rule m a  set (upper_closure rs) 
            (a = action.Accept  a = action.Drop) 
             normalized_nnf_match m 
             normalized_src_ports m 
             normalized_dst_ports m 
             normalized_src_ips m 
             normalized_dst_ips m 
             ¬ has_disc is_MultiportPorts m 
             ¬ has_disc is_Extra m"
        using simplers
        unfolding upper_closure_def
        apply(simp add: remdups_rev_set)
        apply(frule transform_remove_unknowns_upper(4))
        apply(drule transform_remove_unknowns_upper(2))
        thm transform_optimize_dnf_strict[OF _ wf_in_doubt_allow]
        apply(frule(1) transform_optimize_dnf_strict_structure(2)[OF _ wf_in_doubt_allow, where disc=is_Extra])
        apply(thin_tac "r set (optimize_matches_a upper_closure_matchexpr rs). ¬ has_disc is_Extra (get_match r)")
        apply(frule transform_optimize_dnf_strict_structure(3)[OF _ wf_in_doubt_allow])
        apply(drule transform_optimize_dnf_strict_structure(1)[OF _ wf_in_doubt_allow])
        thm transform_normalize_primitives[OF _ wf_in_doubt_allow]
        apply(frule(1) transform_normalize_primitives(3)[OF _ wf_in_doubt_allow, of _ is_Extra])
            apply(simp;fail)
           apply(simp;fail)
          apply(simp;fail)
         apply blast
        apply(thin_tac "r set ?rs2. ¬ has_disc is_Extra (get_match r)")
        apply(frule(1) transform_normalize_primitives(5)[OF _ wf_in_doubt_allow])
        apply(drule transform_normalize_primitives(2)[OF _ wf_in_doubt_allow], simp)
        thm transform_optimize_dnf_strict[OF _ wf_in_doubt_allow]
        apply(frule(1) transform_optimize_dnf_strict_structure(2)[OF _ wf_in_doubt_allow, where disc=is_Extra])
        apply(frule transform_optimize_dnf_strict_structure(2)[OF _ wf_in_doubt_allow, where disc=is_MultiportPorts])
         apply blast
        apply(frule transform_optimize_dnf_strict_structure(3)[OF _ wf_in_doubt_allow])
        apply(frule transform_optimize_dnf_strict_structure(4)[OF _ wf_in_doubt_allow, of _ "(is_Src_Ports, src_ports_sel)" "(λps. case ps of L4Ports _ pts  length pts  1)"])
         apply(simp add: normalized_src_ports_def2; fail)
        apply(frule transform_optimize_dnf_strict_structure(4)[OF _ wf_in_doubt_allow, of _ "(is_Dst_Ports, dst_ports_sel)" "(λps. case ps of L4Ports _ pts  length pts  1)"])
         apply(simp add: normalized_dst_ports_def2; fail)
        apply(frule transform_optimize_dnf_strict_structure(4)[OF _ wf_in_doubt_allow, of _ "(is_Src, src_sel)" normalized_cidr_ip])
         apply(simp add: normalized_src_ips_def2; fail)
        apply(frule transform_optimize_dnf_strict_structure(4)[OF _ wf_in_doubt_allow, of _ "(is_Dst, dst_sel)" normalized_cidr_ip])
         apply(simp add: normalized_dst_ips_def2; fail)
        apply(thin_tac "rset ?rs2. _ r")+
        apply(thin_tac "rset ?rs3. _ r")+
        apply(drule transform_optimize_dnf_strict_structure(1)[OF _ wf_in_doubt_allow])
        apply(subgoal_tac "(a = action.Accept  a = action.Drop)")
         prefer 2
         apply(simp_all add: simple_ruleset_def)
         apply fastforce
        apply(simp add: normalized_src_ports_def2 normalized_dst_ports_def2 normalized_src_ips_def2 normalized_dst_ips_def2)
        apply(intro conjI)
               by fastforce+ (*1s*)
    } note 1=this

    from 1 show "simple_ruleset (upper_closure rs)"
      apply(simp add: simple_ruleset_def)
      apply(clarify)
      apply(rename_tac r)
      apply(case_tac r)
      apply(simp)
      by blast


    from 1 show " r  set (upper_closure rs). normalized_nnf_match (get_match r) 
         normalized_src_ports (get_match r) 
         normalized_dst_ports (get_match r) 
         normalized_src_ips (get_match r) 
         normalized_dst_ips (get_match r) 
         ¬ has_disc is_MultiportPorts (get_match r) 
         ¬ has_disc is_Extra (get_match r)"
      apply(clarify)
      apply(rename_tac r)
      apply(case_tac r)
      apply(simp)
      done
      

    show "a. ¬ disc (Src_Ports a)  a. ¬ disc (Dst_Ports a)  a. ¬ disc (Src a)  a. ¬ disc (Dst a) 
          a. ¬ disc (IIface a)  disc = is_Iiface  a. ¬ disc (OIface a)  disc = is_Oiface 
          a. ¬ disc (Prot a) 
             r  set rs. ¬ has_disc disc (get_match r)   r  set (upper_closure rs). ¬ has_disc disc (get_match r)"
    using simplers
    unfolding upper_closure_def
    apply - 
    apply(frule(1) transform_remove_unknowns_upper(3)[where disc=disc])
    apply(drule transform_remove_unknowns_upper(2))
    apply(frule(1) transform_optimize_dnf_strict_structure(2)[OF _ wf_in_doubt_allow, where disc=disc])
    apply(frule transform_optimize_dnf_strict_structure(3)[OF _ wf_in_doubt_allow])
    apply(drule transform_optimize_dnf_strict_structure(1)[OF _ wf_in_doubt_allow])
    apply(frule(1) transform_normalize_primitives(3)[OF _ wf_in_doubt_allow, of _ disc])
        apply(simp;fail)
       apply blast
      apply(simp;fail)
     apply(simp;fail)
    apply(drule transform_normalize_primitives(2)[OF _ wf_in_doubt_allow], simp)
    apply(frule(1) transform_optimize_dnf_strict_structure(2)[OF _ wf_in_doubt_allow, where disc=disc])
    apply(simp add: remdups_rev_set)
    done

    have no_ports_1:
    "¬ has_disc_negated is_Src_Ports False (get_match m) 
     ¬ has_disc_negated is_Dst_Ports False (get_match m) 
     ¬ has_disc is_MultiportPorts (get_match m)"
    if no_ports: "rset rs.
      ¬ has_disc_negated is_Src_Ports False (get_match r) 
      ¬ has_disc_negated is_Dst_Ports False (get_match r) 
      ¬ has_disc is_MultiportPorts (get_match r)"
    and m: "m  set (transform_optimize_dnf_strict (optimize_matches_a upper_closure_matchexpr rs))"
    for m
    proof -
      from no_ports transform_remove_unknowns_upper(3,6)[OF simplers] have
      "r set (optimize_matches_a upper_closure_matchexpr rs). 
        ¬ has_disc_negated is_Src_Ports False (get_match r) 
        ¬ has_disc_negated is_Dst_Ports False (get_match r) 
        ¬ has_disc is_MultiportPorts (get_match r)"
      by blast
    with m transform_optimize_dnf_strict_structure(2,5)[OF optimize_matches_a_simple_ruleset[OF simplers] wf_in_doubt_allow, of upper_closure_matchexpr]
      show ?thesis by blast
    qed

    show"a. ¬ disc (Src_Ports a)  a. ¬ disc (Dst_Ports a)  a. ¬ disc (Src a)  a. ¬ disc (Dst a) 
         a. ¬ disc (IIface a)  disc = is_Iiface  a. ¬ disc (OIface a)  disc = is_Oiface 
         (a. ¬ disc (Prot a))  disc = is_Prot 
         ( r  set rs. ¬ has_disc_negated is_Src_Ports False (get_match r) 
                        ¬ has_disc_negated is_Dst_Ports False (get_match r) 
                        ¬ has_disc is_MultiportPorts (get_match r)) 
          r  set rs. ¬ has_disc_negated disc False (get_match r) 
          r  set (upper_closure rs). ¬ has_disc_negated disc False (get_match r)"
    using simplers
    unfolding upper_closure_def
    apply - 
    apply(frule(1) transform_remove_unknowns_upper(6)[where disc=disc])
    apply(drule transform_remove_unknowns_upper(2))
    apply(frule(1) transform_optimize_dnf_strict_structure(5)[OF _ wf_in_doubt_allow, where disc=disc])
    apply(frule transform_optimize_dnf_strict_structure(3)[OF _ wf_in_doubt_allow])
    apply(drule transform_optimize_dnf_strict_structure(1)[OF _ wf_in_doubt_allow])
    apply(frule(1) transform_normalize_primitives(7)[OF _ wf_in_doubt_allow, of _ disc])
        apply(simp;fail)
       apply blast
      apply(elim disjE)
       apply blast
      apply(simp)
      using no_ports_1 apply fast
     apply(simp;fail)
    apply(drule transform_normalize_primitives(2)[OF _ wf_in_doubt_allow], simp)
    apply(frule(1) transform_optimize_dnf_strict_structure(5)[OF _ wf_in_doubt_allow, where disc=disc])
    apply(simp add: remdups_rev_set)
    done

    show "(common_matcher, in_doubt_allow),p upper_closure rs, s α t  (common_matcher, in_doubt_allow),p rs, s α t"
    using simplers
    unfolding upper_closure_def
    apply -
    apply(frule transform_remove_unknowns_upper(1)[where p=p and s=s and t=t])
    apply(drule transform_remove_unknowns_upper(2))
    apply(frule transform_optimize_dnf_strict[OF _ wf_in_doubt_allow, where p=p and s=s and t=t])
    apply(frule transform_optimize_dnf_strict_structure(3)[OF _ wf_in_doubt_allow])
    apply(drule transform_optimize_dnf_strict_structure(1)[OF _ wf_in_doubt_allow])
    apply(frule(1) transform_normalize_primitives(1)[OF _ wf_in_doubt_allow, where p=p and s=s and t=t])
    apply(drule transform_normalize_primitives(2)[OF _ wf_in_doubt_allow], simp)
    apply(frule transform_optimize_dnf_strict[OF _ wf_in_doubt_allow, where p=p and s=s and t=t])
    apply(drule transform_optimize_dnf_strict_structure(1)[OF _ wf_in_doubt_allow])
    apply(simp)
    using approximating_bigstep_fun_remdups_rev
    by (simp add: approximating_bigstep_fun_remdups_rev approximating_semantics_iff_fun_good_ruleset remdups_rev_simplers simple_imp_good_ruleset) 
  qed


(*copy&paste from transform_upper_closure*)
lemma transform_lower_closure:
  assumes simplers: "simple_ruleset rs"
  ― ‹semantics are preserved›
  shows "(common_matcher, in_doubt_deny),p lower_closure rs, s α t  (common_matcher, in_doubt_deny),p rs, s α t"
  and "simple_ruleset (lower_closure rs)"
  ― ‹simple, normalized rules without unknowns›
  and " r  set (lower_closure rs). normalized_nnf_match (get_match r) 
                                     normalized_src_ports (get_match r) 
                                     normalized_dst_ports (get_match r) 
                                     normalized_src_ips (get_match r) 
                                     normalized_dst_ips (get_match r) 
                                     ¬ has_disc is_MultiportPorts (get_match r) 
                                     ¬ has_disc is_Extra (get_match r)"
  ― ‹no new primitives are introduced›
  and "a. ¬ disc (Src_Ports a)  a. ¬ disc (Dst_Ports a)  a. ¬ disc (Src a)  a. ¬ disc (Dst a) 
       a. ¬ disc (IIface a)  disc = is_Iiface  a. ¬ disc (OIface a)  disc = is_Oiface 
       a. ¬ disc (Prot a) 
         r  set rs. ¬ has_disc disc (get_match r) 
         r  set (lower_closure rs). ¬ has_disc disc (get_match r)"
  and "a. ¬ disc (Src_Ports a)  a. ¬ disc (Dst_Ports a)  a. ¬ disc (Src a)  a. ¬ disc (Dst a) 
       a. ¬ disc (IIface a)  disc = is_Iiface  a. ¬ disc (OIface a)  disc = is_Oiface 
       (a. ¬ disc (Prot a))  disc = is_Prot 
       ( r  set rs. ¬ has_disc_negated is_Src_Ports False (get_match r) 
                      ¬ has_disc_negated is_Dst_Ports False (get_match r) 
                      ¬ has_disc is_MultiportPorts (get_match r)) 
        r  set rs. ¬ has_disc_negated disc False (get_match r) 
        r  set (lower_closure rs). ¬ has_disc_negated disc False (get_match r)"
  proof -
    let ?rs1="optimize_matches_a lower_closure_matchexpr rs"
    let ?rs2="transform_optimize_dnf_strict ?rs1"
    let ?rs3="transform_normalize_primitives ?rs2"
    let ?rs4="transform_optimize_dnf_strict ?rs3"

    { fix m a
        have "Rule m a  set (lower_closure rs) 
            (a = action.Accept  a = action.Drop) 
             normalized_nnf_match m 
             normalized_src_ports m 
             normalized_dst_ports m 
             normalized_src_ips m 
             normalized_dst_ips m 
             ¬ has_disc is_MultiportPorts m 
              ¬ has_disc is_Extra m"
        using simplers
        unfolding lower_closure_def
        apply(simp add: remdups_rev_set)
        apply(frule transform_remove_unknowns_lower(4))
        apply(drule transform_remove_unknowns_lower(2))
        thm transform_optimize_dnf_strict[OF _ wf_in_doubt_deny]
        apply(frule(1) transform_optimize_dnf_strict_structure(2)[OF _ wf_in_doubt_deny, where disc=is_Extra])
        apply(thin_tac "r set (optimize_matches_a lower_closure_matchexpr rs). ¬ has_disc is_Extra (get_match r)")
        apply(frule transform_optimize_dnf_strict_structure(3)[OF _ wf_in_doubt_deny])
        apply(drule transform_optimize_dnf_strict_structure(1)[OF _ wf_in_doubt_deny])
        thm transform_normalize_primitives[OF _ wf_in_doubt_deny]
        apply(frule(1) transform_normalize_primitives(3)[OF _ wf_in_doubt_deny, of _ is_Extra])
            apply(simp;fail)
           apply(simp;fail)
          apply(simp;fail)
         apply blast
        apply(thin_tac "r set ?rs2. ¬ has_disc is_Extra (get_match r)")
        apply(frule(1) transform_normalize_primitives(5)[OF _ wf_in_doubt_deny])
        apply(drule transform_normalize_primitives(2)[OF _ wf_in_doubt_deny], simp)
        thm transform_optimize_dnf_strict[OF _ wf_in_doubt_deny]
        apply(frule(1) transform_optimize_dnf_strict_structure(2)[OF _ wf_in_doubt_deny, where disc=is_Extra])
        apply(frule transform_optimize_dnf_strict_structure(2)[OF _ wf_in_doubt_deny, where disc=is_MultiportPorts])
         apply blast
        apply(frule transform_optimize_dnf_strict_structure(3)[OF _ wf_in_doubt_deny])
        apply(frule transform_optimize_dnf_strict_structure(4)[OF _ wf_in_doubt_deny, of _ "(is_Src_Ports, src_ports_sel)" "(λps. case ps of L4Ports _ pts  length pts  1)"])
         apply(simp add: normalized_src_ports_def2; fail)
        apply(frule transform_optimize_dnf_strict_structure(4)[OF _ wf_in_doubt_deny, of _ "(is_Dst_Ports, dst_ports_sel)" "(λps. case ps of L4Ports _ pts  length pts  1)"])
         apply(simp add: normalized_dst_ports_def2; fail)
        apply(frule transform_optimize_dnf_strict_structure(4)[OF _ wf_in_doubt_deny, of _ "(is_Src, src_sel)" normalized_cidr_ip])
         apply(simp add: normalized_src_ips_def2; fail)
        apply(frule transform_optimize_dnf_strict_structure(4)[OF _ wf_in_doubt_deny, of _ "(is_Dst, dst_sel)" normalized_cidr_ip])
         apply(simp add: normalized_dst_ips_def2; fail)
        apply(thin_tac "rset ?rs2. _ r")+
        apply(thin_tac "rset ?rs3. _ r")+
        apply(drule transform_optimize_dnf_strict_structure(1)[OF _ wf_in_doubt_deny])
        apply(subgoal_tac "(a = action.Accept  a = action.Drop)")
         prefer 2
         apply(simp_all add: simple_ruleset_def)
         apply fastforce
        apply(simp add: normalized_src_ports_def2 normalized_dst_ports_def2 normalized_src_ips_def2 normalized_dst_ips_def2)
        apply(intro conjI)
               by fastforce+ (*1s*)
    } note 1=this

    from 1 show "simple_ruleset (lower_closure rs)"
      apply(simp add: simple_ruleset_def)
      apply(clarify)
      apply(rename_tac r)
      apply(case_tac r)
      apply(simp)
      by blast


    from 1 show " r  set (lower_closure rs). normalized_nnf_match (get_match r) 
         normalized_src_ports (get_match r) 
         normalized_dst_ports (get_match r) 
         normalized_src_ips (get_match r) 
         normalized_dst_ips (get_match r) 
         ¬ has_disc is_MultiportPorts (get_match r) 
         ¬ has_disc is_Extra (get_match r)"
      apply(clarify)
      apply(rename_tac r)
      apply(case_tac r)
      apply(simp)
      done
      

    show "a. ¬ disc (Src_Ports a)  a. ¬ disc (Dst_Ports a)  a. ¬ disc (Src a)  a. ¬ disc (Dst a) 
          a. ¬ disc (IIface a)  disc = is_Iiface  a. ¬ disc (OIface a)  disc = is_Oiface 
          a. ¬ disc (Prot a) 
             r  set rs. ¬ has_disc disc (get_match r)   r  set (lower_closure rs). ¬ has_disc disc (get_match r)"
    using simplers
    unfolding lower_closure_def
    apply - 
    apply(frule(1) transform_remove_unknowns_lower(3)[where disc=disc])
    apply(drule transform_remove_unknowns_lower(2))
    apply(frule(1) transform_optimize_dnf_strict_structure(2)[OF _ wf_in_doubt_deny, where disc=disc])
    apply(frule transform_optimize_dnf_strict_structure(3)[OF _ wf_in_doubt_deny])
    apply(drule transform_optimize_dnf_strict_structure(1)[OF _ wf_in_doubt_deny])
    apply(frule(1) transform_normalize_primitives(3)[OF _ wf_in_doubt_deny, of _ disc])
        apply(simp;fail)
       apply blast
      apply(simp;fail)
     apply(simp;fail)
    apply(drule transform_normalize_primitives(2)[OF _ wf_in_doubt_deny], simp)
    apply(frule(1) transform_optimize_dnf_strict_structure(2)[OF _ wf_in_doubt_deny, where disc=disc])
    apply(simp add: remdups_rev_set)
    done

    have no_ports_1:
    "¬ has_disc_negated is_Src_Ports False (get_match m) 
     ¬ has_disc_negated is_Dst_Ports False (get_match m) 
     ¬ has_disc is_MultiportPorts (get_match m)"
    if no_ports: "rset rs.
      ¬ has_disc_negated is_Src_Ports False (get_match r) 
      ¬ has_disc_negated is_Dst_Ports False (get_match r) 
      ¬ has_disc is_MultiportPorts (get_match r)"
    and m: "m  set (transform_optimize_dnf_strict (optimize_matches_a lower_closure_matchexpr rs))"
    for m
    proof -
      from no_ports transform_remove_unknowns_lower(3,6)[OF simplers] have
      "r set (optimize_matches_a lower_closure_matchexpr rs). 
        ¬ has_disc_negated is_Src_Ports False (get_match r) 
        ¬ has_disc_negated is_Dst_Ports False (get_match r) 
        ¬ has_disc is_MultiportPorts (get_match r)"
      by blast
    from m this transform_optimize_dnf_strict_structure(2,5)[OF optimize_matches_a_simple_ruleset[OF simplers] wf_in_doubt_deny, of lower_closure_matchexpr]
      show ?thesis by blast
    qed

    show"a. ¬ disc (Src_Ports a)  a. ¬ disc (Dst_Ports a)  a. ¬ disc (Src a)  a. ¬ disc (Dst a) 
         a. ¬ disc (IIface a)  disc = is_Iiface  a. ¬ disc (OIface a)  disc = is_Oiface 
         (a. ¬ disc (Prot a))  disc = is_Prot 
         ( r  set rs. ¬ has_disc_negated is_Src_Ports False (get_match r) 
                        ¬ has_disc_negated is_Dst_Ports False (get_match r) 
                        ¬ has_disc is_MultiportPorts (get_match r)) 
         r  set rs. ¬ has_disc_negated disc False (get_match r) 
         r  set (lower_closure rs). ¬ has_disc_negated disc False (get_match r)"
    using simplers
    unfolding lower_closure_def
    apply - 
    apply(frule(1) transform_remove_unknowns_lower(6)[where disc=disc])
    apply(drule transform_remove_unknowns_lower(2))
    apply(frule(1) transform_optimize_dnf_strict_structure(5)[OF _ wf_in_doubt_deny, where disc=disc])
    apply(frule transform_optimize_dnf_strict_structure(3)[OF _ wf_in_doubt_deny])
    apply(drule transform_optimize_dnf_strict_structure(1)[OF _ wf_in_doubt_deny])
    apply(frule(1) transform_normalize_primitives(7)[OF _ wf_in_doubt_deny, of _ disc])
        apply(simp;fail)
       apply blast
      apply(elim disjE)
       apply blast
      apply(simp)
      using no_ports_1 apply fast
     apply(simp;fail)
    apply(drule transform_normalize_primitives(2)[OF _ wf_in_doubt_deny], simp)
    apply(frule(1) transform_optimize_dnf_strict_structure(5)[OF _ wf_in_doubt_deny, where disc=disc])
    apply(simp add: remdups_rev_set)
    done

    show "(common_matcher, in_doubt_deny),p lower_closure rs, s α t  (common_matcher, in_doubt_deny),p rs, s α t"
    using simplers
    unfolding lower_closure_def
    apply -
    apply(frule transform_remove_unknowns_lower(1)[where p=p and s=s and t=t])
    apply(drule transform_remove_unknowns_lower(2))
    apply(frule transform_optimize_dnf_strict[OF _ wf_in_doubt_deny, where p=p and s=s and t=t])
    apply(frule transform_optimize_dnf_strict_structure(3)[OF _ wf_in_doubt_deny])
    apply(drule transform_optimize_dnf_strict_structure(1)[OF _ wf_in_doubt_deny])
    apply(frule(1) transform_normalize_primitives(1)[OF _ wf_in_doubt_deny, where p=p and s=s and t=t])
    apply(drule transform_normalize_primitives(2)[OF _ wf_in_doubt_deny], simp)
    apply(frule transform_optimize_dnf_strict[OF _ wf_in_doubt_deny, where p=p and s=s and t=t])
    apply(drule transform_optimize_dnf_strict_structure(1)[OF _ wf_in_doubt_deny])
    apply(simp)
    using approximating_bigstep_fun_remdups_rev
    by (simp add: approximating_bigstep_fun_remdups_rev approximating_semantics_iff_fun_good_ruleset remdups_rev_simplers simple_imp_good_ruleset) 
  qed


definition iface_try_rewrite
  :: "(iface × ('i::len word × nat) list) list
    'i prefix_routing option
    'i common_primitive rule list
       'i common_primitive rule list"
where
  "iface_try_rewrite ipassmt rtblo rs  
  let o_rewrite = (case rtblo of None  id | Some rtbl  
    transform_optimize_dnf_strict  optimize_matches (oiface_rewrite (map_of_ipassmt (routing_ipassmt rtbl)))) in
  if ipassmt_sanity_disjoint (map_of ipassmt)  ipassmt_sanity_defined rs (map_of ipassmt) then
  optimize_matches (iiface_rewrite (map_of_ipassmt ipassmt)) (o_rewrite rs)
  else
  optimize_matches (iiface_constrain (map_of_ipassmt ipassmt)) (o_rewrite rs)"

text‹Where @{typ "(iface × ('i::len word × nat) list) list"} is @{const map_of}@{typ "'i::len ipassignment"}. 
 The sanity checkers need to iterate over the interfaces, hence we don't pass a map but a list of tuples.›


text‹In @{file ‹Transform.thy›} there should be the final correctness theorem for iface_try_rewrite›. 
     Here are some structural properties.›


lemma iface_try_rewrite_simplers: "simple_ruleset rs  simple_ruleset (iface_try_rewrite ipassmt rtblo rs)"
  by(simp add: iface_try_rewrite_def optimize_matches_simple_ruleset transform_optimize_dnf_strict_structure(1)[OF _ wf_in_doubt_allow 
     (* The wf_unknown_match_tac is only required for some other parts of that lemma group, so any wellfounded tactic will do. *)] Let_def split: option.splits)
    

lemma iiface_rewrite_preserves_nodisc:
  "a. ¬ disc (Src a)  ¬ has_disc disc m  ¬ has_disc disc (iiface_rewrite ipassmt m)"
  proof(induction ipassmt m rule: iiface_rewrite.induct)
  case 2 
    have "a. ¬ disc (Src a)  ¬ disc (IIface ifce)  ¬ has_disc disc (ipassmt_iface_replace_srcip_mexpr ipassmt ifce)"
      for ifce ipassmt
      apply(simp add: ipassmt_iface_replace_srcip_mexpr_def split: option.split)
      apply(intro allI impI, rename_tac ips)
      apply(drule_tac X=Src and ls="map (uncurry IpAddrNetmask) ips" in match_list_to_match_expr_not_has_disc)
      apply(simp)
      done
    with 2 show ?case by simp
  qed(simp_all)

lemma iiface_constrain_preserves_nodisc:
  "a. ¬ disc (Src a)  ¬ has_disc disc m  ¬ has_disc disc (iiface_constrain ipassmt m)"
  proof(induction ipassmt m rule: iiface_rewrite.induct)
  case 2 
    have "a. ¬ disc (Src a)  ¬ disc (IIface ifce)  ¬ has_disc disc (ipassmt_iface_constrain_srcip_mexpr ipassmt ifce)"
      for ifce ipassmt
      apply(simp add: ipassmt_iface_constrain_srcip_mexpr_def split: option.split)
      apply(intro allI impI, rename_tac ips)
      apply(drule_tac X=Src and ls="map (uncurry IpAddrNetmask) ips" in match_list_to_match_expr_not_has_disc)
      apply(simp)
      done
    with 2 show ?case by simp
  qed(simp_all)


lemma iface_try_rewrite_preserves_nodisc: "
      simple_ruleset rs 
      a. ¬ disc (Src a)  a. ¬ disc (Dst a)  
      r set rs. ¬ has_disc disc (get_match r) 
        r set (iface_try_rewrite ipassmt rtblo rs). ¬ has_disc disc (get_match r)"   
  apply(insert wf_in_doubt_deny) (* to appease transform_optimize_dnf_strict_structure *)
  apply(simp add: iface_try_rewrite_def Let_def)
  apply(intro conjI impI optimize_matches_preserves)
  apply(case_tac[!] rtblo)
     apply(simp_all add: oiface_rewrite_preserves_nodisc iiface_rewrite_preserves_nodisc iiface_constrain_preserves_nodisc) (* solves the two None-cases *)
   apply(rule iiface_rewrite_preserves_nodisc; assumption?)
   apply(rule transform_optimize_dnf_strict_structure(2)[THEN bspec]; (assumption|simp add: optimize_matches_simple_ruleset; fail)?)
   apply(rule optimize_matches_preserves)
   apply(rule oiface_rewrite_preserves_nodisc; simp; fail)
  apply(rule iiface_constrain_preserves_nodisc; assumption?)
  apply(rule transform_optimize_dnf_strict_structure(2)[THEN bspec]; (assumption|simp add: optimize_matches_simple_ruleset; fail)?)
  apply(rule optimize_matches_preserves)
  apply(rule oiface_rewrite_preserves_nodisc; simp; fail)
done


theorem iface_try_rewrite_no_rtbl:
  assumes simplers: "simple_ruleset rs"
      and normalized: " r  set rs. normalized_nnf_match (get_match r)"
      and wf_ipassmt1: "ipassmt_sanity_nowildcards (map_of ipassmt)" and wf_ipassmt2: "distinct (map fst ipassmt)"
      and nospoofing: "ips. (map_of ipassmt) (Iface (p_iiface p)) = Some ips  p_src p  ipcidr_union_set (set ips)"
  shows "(common_matcher, α),p iface_try_rewrite ipassmt None rs, s α t  (common_matcher, α),p rs, s α t"
proof -
  show "(common_matcher, α),p iface_try_rewrite ipassmt None rs, s α t  (common_matcher, α),p rs, s α t"
    apply(simp add: iface_try_rewrite_def Let_def comp_def)
    apply(simp add: map_of_ipassmt_def wf_ipassmt1 wf_ipassmt2)
    apply(intro conjI impI)
     apply(elim conjE)
     using iiface_rewrite(1)[OF simplers normalized wf_ipassmt1 _ nospoofing] apply blast
    using iiface_constrain(1)[OF simplers normalized wf_ipassmt1, where p = p] nospoofing apply force
    done
qed

lemma optimize_matches_comp:
  assumes mono: "m. matcheq_matchNone m  matcheq_matchNone (g m)"
  shows "optimize_matches (g  f) rs = optimize_matches g ((optimize_matches f)  rs)"
unfolding optimize_matches_def
proof(induction rs)
  case (Cons r rs)
  obtain m a where [simp]: "r = Rule m a" by(cases r)
  show ?case 
  proof(cases "matcheq_matchNone (f m)")
    case True
    hence mn: "matcheq_matchNone (g (f m))" by(fact mono)
    show ?thesis by(unfold comp_def (* occasionally, the simplifier is weird *); simp add: mn Cons.IH[unfolded comp_def])
  next
    case False
    show ?thesis by(unfold comp_def; simp add: False Cons.IH[unfolded comp_def])
  qed
qed simp
(* optimize_matches_comp is a really nice lemma. 
The problem is that it is useless because I cannot execute the two rewrites after each other without going back to nnf.
*)
context begin

private lemma iiface_rewrite_monoNone: "matcheq_matchNone m  matcheq_matchNone (iiface_rewrite ipassmt m)"
  by(induction m rule: matcheq_matchNone.induct) auto
private lemma iiface_constrain_monoNone: "matcheq_matchNone m  matcheq_matchNone (iiface_constrain ipassmt m)"
  by(induction m rule: matcheq_matchNone.induct) auto

private lemmas optimize_matches_iiface_comp = optimize_matches_comp[OF iiface_rewrite_monoNone] 
                                      optimize_matches_comp[OF iiface_constrain_monoNone]
end

theorem iface_try_rewrite_rtbl:
  assumes simplers: "simple_ruleset rs"
      and normalized: " r  set rs. normalized_nnf_match (get_match r)"
      and wf_ipassmt: "ipassmt_sanity_nowildcards (map_of ipassmt)" "distinct (map fst ipassmt)"
      and nospoofing: "ips. (map_of ipassmt) (Iface (p_iiface p)) = Some ips  p_src p  ipcidr_union_set (set ips)"
      and routing_decided: "output_iface (routing_table_semantics rtbl (p_dst p)) = p_oiface p"
      and correct_routing: "correct_routing rtbl"
      and wf_ipassmt_o: "ipassmt_sanity_nowildcards (map_of (routing_ipassmt rtbl))"
      and wf_match_tac: "wf_unknown_match_tac α"
  shows "(common_matcher, α),p iface_try_rewrite ipassmt (Some rtbl) rs, s α t  (common_matcher, α),p rs, s α t"
proof -
  note oiface_rewrite = oiface_rewrite[OF simplers normalized wf_ipassmt_o refl correct_routing routing_decided]
  let ?ors = "optimize_matches (oiface_rewrite (map_of (routing_ipassmt rtbl))) rs"
  let ?nrs = "transform_optimize_dnf_strict ?ors"
  have osimplers: "simple_ruleset ?ors" using oiface_rewrite(2) .
  have nsimplers: "simple_ruleset ?nrs" using transform_optimize_dnf_strict_structure(1)[OF osimplers wf_match_tac] .
  have nnormalized: " r  set ?nrs. normalized_nnf_match (get_match r)" using transform_optimize_dnf_strict_structure(3)[OF osimplers wf_match_tac] .
  note nnf = transform_optimize_dnf_strict[OF osimplers wf_match_tac]
  have nospoofing_alt: "ips. map_of ipassmt (Iface (p_iiface p)) = Some ips  p_src p  ipcidr_union_set (set ips)" using nospoofing by simp
  show "(common_matcher, α),p iface_try_rewrite ipassmt (Some rtbl) rs, s α t  (common_matcher, α),p rs, s α t"
    apply(simp add: iface_try_rewrite_def Let_def)
    apply(simp add: map_of_ipassmt_def wf_ipassmt routing_ipassmt_distinct wf_ipassmt_o)
    apply(intro conjI impI; (elim conjE)?)
    subgoal using iiface_rewrite(1)[OF nsimplers nnormalized wf_ipassmt(1) _ nospoofing] oiface_rewrite(1) nnf by simp
    subgoal using iiface_constrain(1)[OF nsimplers nnormalized wf_ipassmt(1), where p = p] nospoofing_alt oiface_rewrite(1) nnf by simp
    done
qed

  

end

Theory Conntrack_State_Transform

theory Conntrack_State_Transform
imports Common_Primitive_Matcher
        "../Semantics_Ternary/Semantics_Ternary"
begin


text‹The following function assumes that the packet is in a certain state.›

fun ctstate_assume_state :: "ctstate  'i::len  common_primitive match_expr  'i common_primitive match_expr" where
  "ctstate_assume_state s (Match (CT_State x)) = (if s  x then MatchAny else MatchNot MatchAny)" |
  "ctstate_assume_state s (Match m) = Match m" |
  "ctstate_assume_state s (MatchNot m) = MatchNot (ctstate_assume_state s m)" |
  "ctstate_assume_state _ MatchAny = MatchAny" |
  "ctstate_assume_state s (MatchAnd m1 m2) = MatchAnd (ctstate_assume_state s m1) (ctstate_assume_state s m2)"

lemma ctstate_assume_state: "p_tag_ctstate p = s 
    matches (common_matcher, α) (ctstate_assume_state s m) a p  matches (common_matcher, α) m a p"
apply(rule matches_iff_apply_f)
by(induction m rule: ctstate_assume_state.induct) (simp_all)


definition ctstate_assume_new :: "'i::len  common_primitive rule list  'i common_primitive rule list" where
  "ctstate_assume_new  optimize_matches (ctstate_assume_state CT_New)"

lemma ctstate_assume_new_simple_ruleset: "simple_ruleset rs  simple_ruleset (ctstate_assume_new rs)"
  by (simp add: ctstate_assume_new_def optimize_matches_simple_ruleset)

text‹Usually, the interesting part of a firewall is only about the rules for setting up connections.
      That means, we mostly only care about packets in state @{const CT_New}.
      Use the function @{const ctstate_assume_new} to remove all state matching and just care about
      the connection setup.
›
corollary ctstate_assume_new: "p_tag_ctstate p = CT_New  
  approximating_bigstep_fun (common_matcher, α) p (ctstate_assume_new rs) s = approximating_bigstep_fun (common_matcher, α) p rs s"
unfolding ctstate_assume_new_def
apply(rule optimize_matches)
apply(simp add: ctstate_assume_state)
done

text‹If we assume the CT State is @{const CT_New}, we can also assume that the TCP SYN flag (@{const ipt_tcp_syn}) is set.›

fun ipt_tcp_flags_assume_flag :: "ipt_tcp_flags  'i::len common_primitive match_expr  'i common_primitive match_expr" where
  "ipt_tcp_flags_assume_flag flg (Match (L4_Flags x)) = (if ipt_tcp_flags_equal x flg then MatchAny else (case match_tcp_flags_conjunct_option x flg of None  MatchNot MatchAny | Some f3  Match (L4_Flags f3)))" |
  "ipt_tcp_flags_assume_flag flg (Match m) = Match m" |
  "ipt_tcp_flags_assume_flag flg (MatchNot m) = MatchNot (ipt_tcp_flags_assume_flag flg m)" |
  "ipt_tcp_flags_assume_flag _ MatchAny = MatchAny" |
  "ipt_tcp_flags_assume_flag flg (MatchAnd m1 m2) = MatchAnd (ipt_tcp_flags_assume_flag flg m1) (ipt_tcp_flags_assume_flag flg m2)"

lemma ipt_tcp_flags_assume_flag: assumes "match_tcp_flags flg (p_tcp_flags p)"
    shows "matches (common_matcher, α) (ipt_tcp_flags_assume_flag flg m) a p  matches (common_matcher, α) m a p"
proof(rule matches_iff_apply_f)
show "ternary_ternary_eval (map_match_tac common_matcher p (ipt_tcp_flags_assume_flag flg m)) = ternary_ternary_eval (map_match_tac common_matcher p m)"
  using assms proof(induction m rule: ipt_tcp_flags_assume_flag.induct)
  case (1 flg x)
    thus ?case
    apply(simp add: ipt_tcp_flags_equal del: match_tcp_flags.simps)
    apply(cases "match_tcp_flags_conjunct_option x flg")
     apply(simp)
     using match_tcp_flags_conjunct_option_None bool_to_ternary_simps(2) apply metis
    apply(simp)
    apply(drule_tac pkt="(p_tcp_flags p)" in match_tcp_flags_conjunct_option_Some)
    by simp
  qed(simp_all del: match_tcp_flags.simps)
qed

definition ipt_tcp_flags_assume_syn :: "'i::len common_primitive rule list  'i common_primitive rule list" where
  "ipt_tcp_flags_assume_syn  optimize_matches (ipt_tcp_flags_assume_flag ipt_tcp_syn)"

lemma ipt_tcp_flags_assume_syn_simple_ruleset: "simple_ruleset rs  simple_ruleset (ipt_tcp_flags_assume_syn rs)"
  by (simp add: ipt_tcp_flags_assume_syn_def optimize_matches_simple_ruleset)

corollary ipt_tcp_flags_assume_syn: "match_tcp_flags ipt_tcp_syn (p_tcp_flags p) 
  approximating_bigstep_fun (common_matcher, α) p (ipt_tcp_flags_assume_syn rs) s = approximating_bigstep_fun (common_matcher, α) p rs s"
unfolding ipt_tcp_flags_assume_syn_def
apply(rule optimize_matches)
apply(simp add: ipt_tcp_flags_assume_flag)
done





definition packet_assume_new :: "'i::len common_primitive rule list  'i common_primitive rule list" where
  "packet_assume_new  ctstate_assume_new  ipt_tcp_flags_assume_syn"

lemma packet_assume_new_simple_ruleset: "simple_ruleset rs  simple_ruleset (packet_assume_new rs)"
  by (simp add: packet_assume_new_def ipt_tcp_flags_assume_syn_simple_ruleset ctstate_assume_new_simple_ruleset)

corollary packet_assume_new: "match_tcp_flags ipt_tcp_syn (p_tcp_flags p)  p_tag_ctstate p = CT_New  
  approximating_bigstep_fun (common_matcher, α) p (packet_assume_new rs) s = approximating_bigstep_fun (common_matcher, α) p rs s"
unfolding packet_assume_new_def
by (simp add: ctstate_assume_new ipt_tcp_flags_assume_syn)

  



end

Theory Primitive_Abstract

theory Primitive_Abstract
imports
  Common_Primitive_toString
  Transform
  Conntrack_State_Transform
begin

section‹Abstracting over Primitives›



text‹Abstract over certain primitives. The first parameter is a function
  @{typ "'i::len common_primitive negation_type  bool"} to select the primitives to be abstracted over.
  The @{typ "'i::len common_primitive"} is wrapped in a @{typ "'i::len common_primitive negation_type"} to let the function
  selectively abstract only over negated, non-negated, or both kinds of primitives.
  This functions requires a @{const normalized_nnf_match}.
›
(*requires toString function!*)
fun abstract_primitive
  :: "('i::len common_primitive negation_type  bool)  'i common_primitive match_expr  'i common_primitive match_expr"
where
  "abstract_primitive _     MatchAny = MatchAny" |
  "abstract_primitive disc (Match a) =
      (if
         disc (Pos a)
       then
         Match (Extra (common_primitive_toString ipaddr_generic_toString a))
       else
         (Match a))" |
  "abstract_primitive disc (MatchNot (Match a)) =
      (if
         disc (Neg a)
       then
         Match (Extra (''! ''@common_primitive_toString ipaddr_generic_toString a))
       else
         (MatchNot (Match a)))" |
  "abstract_primitive disc (MatchNot m) = MatchNot (abstract_primitive disc m)" |
  "abstract_primitive disc (MatchAnd m1 m2) = MatchAnd (abstract_primitive disc m1) (abstract_primitive disc m2)"


text‹For example, a simple firewall requires that no negated interfaces and protocols occur in the 
      expression.›
definition abstract_for_simple_firewall :: "'i::len common_primitive match_expr  'i common_primitive match_expr"
  where "abstract_for_simple_firewall  abstract_primitive (λr. case r
                of Pos a  is_CT_State a  is_L4_Flags a
                |  Neg a  is_Iiface a  is_Oiface a  is_Prot a  is_CT_State a  is_L4_Flags a)"


lemma abstract_primitive_preserves_normalized:
  "normalized_src_ports m  normalized_src_ports (abstract_primitive disc m)"
  "normalized_dst_ports m  normalized_dst_ports (abstract_primitive disc m)"
  "normalized_src_ips m  normalized_src_ips (abstract_primitive disc m)"
  "normalized_dst_ips m  normalized_dst_ips (abstract_primitive disc m)"
  "normalized_nnf_match m  normalized_nnf_match (abstract_primitive disc m)"
  by(induction disc m rule: abstract_primitive.induct) (simp_all)
lemma abstract_primitive_preserves_nodisc:
  "¬ has_disc disc' m  (str. ¬ disc' (Extra str))  ¬ has_disc disc' (abstract_primitive disc m)"
  by(induction disc m rule: abstract_primitive.induct)(simp_all)
lemma abstract_primitive_preserves_nodisc_nedgated:
  "¬ has_disc_negated disc' neg m  (str. ¬ disc' (Extra str))  ¬ has_disc_negated disc' neg (abstract_primitive disc m)"
  by(induction disc m arbitrary: neg rule: abstract_primitive.induct) simp+

lemma abstract_primitive_nodisc:
  "x. disc' x  disc (Pos x)  disc (Neg x)   (str. ¬ disc' (Extra str))  ¬ has_disc disc' (abstract_primitive disc m)"
  by(induction disc m rule: abstract_primitive.induct) auto
  
lemma abstract_primitive_preserves_not_has_disc_negated:
  "a. ¬ disc (Extra a) ¬ has_disc_negated disc neg m  ¬ has_disc_negated disc neg (abstract_primitive sel_f m)"
by(induction sel_f m arbitrary: neg rule: abstract_primitive.induct) simp+

lemma abstract_for_simple_firewall_preserves_nodisc_negated:
  "a. ¬ disc (Extra a) ¬ has_disc_negated disc False m  ¬ has_disc_negated disc False (abstract_for_simple_firewall m)"
unfolding abstract_for_simple_firewall_def
using abstract_primitive_preserves_nodisc_nedgated by blast

text‹The function @{const ctstate_assume_state} can be used to fix a state and hence remove all state matches from the ruleset.
      It is therefore advisable to create a simple firewall for a fixed state, e.g. with @{const ctstate_assume_new} before
      calling to @{const abstract_for_simple_firewall}.›
lemma not_hasdisc_ctstate_assume_state: "¬ has_disc is_CT_State (ctstate_assume_state s m)"
  by(induction m rule: ctstate_assume_state.induct) (simp_all)


lemma abstract_for_simple_firewall_hasdisc: fixes m :: "'i::len common_primitive match_expr"
  shows "¬ has_disc is_CT_State (abstract_for_simple_firewall m)"
  and   "¬ has_disc is_L4_Flags (abstract_for_simple_firewall m)"
  unfolding abstract_for_simple_firewall_def
  apply(induction "(λr:: 'i common_primitive negation_type. case r of Pos a  is_CT_State a | Neg a  is_Iiface a  is_Oiface a  is_Prot a  is_CT_State a)" m rule: abstract_primitive.induct)
  apply(simp_all)
  done

lemma abstract_for_simple_firewall_negated_ifaces_prots: fixes m :: "'i::len common_primitive match_expr"
  shows  "normalized_nnf_match m  ¬ has_disc_negated (λa. is_Iiface a  is_Oiface a) False (abstract_for_simple_firewall m)"
  and "normalized_nnf_match m  ¬ has_disc_negated is_Prot False (abstract_for_simple_firewall m)"
  unfolding abstract_for_simple_firewall_def
  apply(induction "(λr:: 'i common_primitive negation_type. case r of Pos a  is_CT_State a | Neg a  is_Iiface a  is_Oiface a  is_Prot a  is_CT_State a)" m rule: abstract_primitive.induct)
  apply(simp_all)
  done


context
begin
  private lemma abstract_primitive_in_doubt_allow_Allow: 
    "primitive_matcher_generic β  normalized_nnf_match m  
      matches (β, in_doubt_allow) m action.Accept p 
      matches (β, in_doubt_allow) (abstract_primitive disc m) action.Accept p"
     by(induction disc m rule: abstract_primitive.induct)
       (simp_all add: bunch_of_lemmata_about_matches(1) primitive_matcher_generic.Extra_single)
  
  private lemma abstract_primitive_in_doubt_allow_Allow2: 
    "primitive_matcher_generic β  normalized_nnf_match m  
      ¬ matches (β, in_doubt_allow) m action.Drop p 
      ¬ matches (β, in_doubt_allow) (abstract_primitive disc m) action.Drop p"
     proof(induction disc m rule: abstract_primitive.induct)
     case(5 m1 m2) thus ?case by (auto simp add: bunch_of_lemmata_about_matches(1))
     qed(simp_all add: bunch_of_lemmata_about_matches(1) primitive_matcher_generic.Extra_single)

  private lemma abstract_primitive_in_doubt_allow_Deny: 
    "primitive_matcher_generic β  normalized_nnf_match m 
      matches (β, in_doubt_allow) (abstract_primitive disc m) action.Drop p 
      matches (β, in_doubt_allow) m action.Drop p"
     apply(induction disc m rule: abstract_primitive.induct)
           apply (simp_all add: bunch_of_lemmata_about_matches(1))
       apply(auto simp add: primitive_matcher_generic.Extra_single primitive_matcher_generic.Extra_single_not split: if_split_asm)
     done
  
  private lemma abstract_primitive_in_doubt_allow_Deny2: 
    "primitive_matcher_generic β  normalized_nnf_match m  
      ¬ matches (β, in_doubt_allow) (abstract_primitive disc m) action.Accept p 
      ¬ matches (β, in_doubt_allow) m action.Accept p"
     apply(induction disc m rule: abstract_primitive.induct)
           apply (simp_all add: bunch_of_lemmata_about_matches(1))
       apply(auto simp add: primitive_matcher_generic.Extra_single primitive_matcher_generic.Extra_single_not split: if_split_asm)
     done
  
  theorem abstract_primitive_in_doubt_allow_generic:
    fixes β::"('i::len common_primitive, ('i, 'a) tagged_packet_scheme) exact_match_tac"
    assumes generic: "primitive_matcher_generic β"
       and n: " r  set rs. normalized_nnf_match (get_match r)"
       and simple: "simple_ruleset rs"
    defines "γ  (β, in_doubt_allow)" and "abstract disc  optimize_matches (abstract_primitive disc)"
    shows   "{p. γ,p abstract disc rs, Undecided α Decision FinalDeny}  {p. γ,p rs, Undecided α Decision FinalDeny}"
                (is ?deny)
      and   "{p. γ,p rs, Undecided α Decision FinalAllow}  {p. γ,p abstract disc rs, Undecided α Decision FinalAllow}"
                (is ?allow)
    proof -
      from simple have "good_ruleset rs" using simple_imp_good_ruleset by fast
      from optimize_matches_simple_ruleset simple simple_imp_good_ruleset have
       good: "good_ruleset (optimize_matches (abstract_primitive disc) rs)" by fast

      let ="(β, in_doubt_allow) :: ('i::len common_primitive, ('i, 'a) tagged_packet_scheme) match_tac"
        ― ‹type signature is needed, otherwise @{const in_doubt_allow} would be for arbitrary packet›

      have abstract_primitive_in_doubt_allow_help1:
        "approximating_bigstep_fun γ p (optimize_matches (abstract_primitive disc) rs) Undecided = Decision FinalAllow"
        if prem: "approximating_bigstep_fun γ p rs Undecided = Decision FinalAllow" for p
        proof -
          from simple have "wf_ruleset γ p rs" using good_imp_wf_ruleset simple_imp_good_ruleset by fast
          from this simple prem n show ?thesis
            unfolding γ_def
            proof(induction  p rs Undecided rule: approximating_bigstep_fun_induct_wf)
            case (MatchAccept p m a rs)
              from MatchAccept.prems
                abstract_primitive_in_doubt_allow_Allow[OF generic] MatchAccept.hyps have
                "matches  (abstract_primitive disc m) action.Accept p" by simp
              thus ?case
              apply(simp add: MatchAccept.hyps(2))
              using optimize_matches_matches_fst by fastforce 
            next
            case (Nomatch p m a rs) thus ?case
              proof(cases "matches  (abstract_primitive disc m) a p")
                case False with Nomatch show ?thesis
                  apply(simp add: optimize_matches_def)
                  using simple_ruleset_tail by blast
                next
                case True
                  from Nomatch.prems(1) have "a = action.Accept  a = action.Drop" by(simp add: simple_ruleset_def)
                  from Nomatch.hyps(1) Nomatch.prems(3) abstract_primitive_in_doubt_allow_Allow2[OF generic] have
                    "a = action.Drop  ¬ matches  (abstract_primitive disc m) action.Drop p" by simp
                  with True a = action.Accept  a = action.Drop› have "a = action.Accept" by blast
                  with True show ?thesis
                    using optimize_matches_matches_fst by fastforce 
                qed
            qed(simp_all add: simple_ruleset_def)
      qed

      have abstract_primitive_in_doubt_allow_help2:
        "approximating_bigstep_fun γ p rs Undecided = Decision FinalDeny"
        if prem: "approximating_bigstep_fun γ p (optimize_matches (abstract_primitive disc) rs) Undecided = Decision FinalDeny"
        for p
        proof -
          from simple have "wf_ruleset γ p rs" using good_imp_wf_ruleset simple_imp_good_ruleset by fast
          from this simple prem n show ?thesis
            unfolding γ_def
            proof(induction  p rs Undecided rule: approximating_bigstep_fun_induct_wf)
            case Empty thus ?case by(simp add: optimize_matches_def)
            next
            case (MatchAccept p m a rs)
              from MatchAccept.prems abstract_primitive_in_doubt_allow_Allow[OF generic] MatchAccept.hyps have
                1: "matches  (abstract_primitive disc m) action.Accept p" by simp
              with MatchAccept have "approximating_bigstep_fun  p
                (Rule (abstract_primitive disc m) action.Accept # (optimize_matches (abstract_primitive disc) rs)) Undecided = Decision FinalDeny"
                using optimize_matches_matches_fst by metis
              with 1 have False by(simp)
              thus ?case ..
            next
            case (Nomatch p m a rs) thus ?case
              proof(cases "matches  (abstract_primitive disc m) a p")
                case False
                with Nomatch.prems(2) have "approximating_bigstep_fun  p (optimize_matches (abstract_primitive disc) rs) Undecided = Decision FinalDeny"
                  by(simp add: optimize_matches_def split: if_split_asm)
                with Nomatch have IH: "approximating_bigstep_fun  p rs Undecided = Decision FinalDeny"
                  using simple_ruleset_tail by auto
                with Nomatch(1) show ?thesis by simp
                next
                case True
                  from Nomatch.prems(2) True have 1: "approximating_bigstep_fun  p
                    (Rule (abstract_primitive disc m) a # (optimize_matches (abstract_primitive disc) rs)) Undecided = Decision FinalDeny"
                    using optimize_matches_matches_fst by metis
                    
                  from Nomatch.prems(1) have "a = action.Accept  a = action.Drop" by(simp add: simple_ruleset_def)
                  from Nomatch.hyps(1) Nomatch.prems(3) abstract_primitive_in_doubt_allow_Allow2[OF generic] have
                    "a = action.Drop  ¬ matches  (abstract_primitive disc m) action.Drop p" by simp
                  with True a = action.Accept  a = action.Drop› have "a = action.Accept" by blast
                  with 1 True have False by simp
                  thus ?thesis ..
                qed
            qed(simp_all add: simple_ruleset_def)
      qed
  
      from good approximating_semantics_iff_fun_good_ruleset abstract_primitive_in_doubt_allow_help1 ‹good_ruleset rs show ?allow
        unfolding abstract_def by fast
      from good approximating_semantics_iff_fun_good_ruleset abstract_primitive_in_doubt_allow_help2 ‹good_ruleset rs γ_def show ?deny 
        unfolding abstract_def by fast
    qed
  corollary abstract_primitive_in_doubt_allow:
    assumes " r  set rs. normalized_nnf_match (get_match r)" and "simple_ruleset rs"
    defines "γ  (common_matcher, in_doubt_allow)" and "abstract disc  optimize_matches (abstract_primitive disc)"
    shows   "{p. γ,p abstract disc rs, Undecided α Decision FinalDeny}  {p. γ,p rs, Undecided α Decision FinalDeny}"
      and   "{p. γ,p rs, Undecided α Decision FinalAllow}  {p. γ,p abstract disc rs, Undecided α Decision FinalAllow}"
    unfolding γ_def abstract_def
    using assms abstract_primitive_in_doubt_allow_generic[OF primitive_matcher_generic_common_matcher] by blast+
end


context
begin
  private lemma abstract_primitive_in_doubt_deny_Deny:
    "primitive_matcher_generic β  normalized_nnf_match m  
      matches (β, in_doubt_deny) m action.Drop p 
      matches (β, in_doubt_deny) (abstract_primitive disc m) action.Drop p"
     by(induction disc m rule: abstract_primitive.induct)
       (simp_all add: bunch_of_lemmata_about_matches(1) primitive_matcher_generic.Extra_single)
  
  private lemma abstract_primitive_in_doubt_deny_Deny2:
    "primitive_matcher_generic β  normalized_nnf_match m  
      ¬ matches (β, in_doubt_deny) m action.Accept p 
      ¬ matches (β, in_doubt_deny) (abstract_primitive disc m) action.Accept p"
     proof(induction disc m rule: abstract_primitive.induct)
     case(5 m1 m2) thus ?case by (auto simp add: bunch_of_lemmata_about_matches(1))
     qed(simp_all add: bunch_of_lemmata_about_matches(1) primitive_matcher_generic.Extra_single)
  
  private lemma abstract_primitive_in_doubt_deny_Allow: 
    "primitive_matcher_generic β  normalized_nnf_match m 
      matches (β, in_doubt_deny) (abstract_primitive disc m) action.Accept p 
      matches (β, in_doubt_deny) m action.Accept p"
     apply(induction disc m rule: abstract_primitive.induct)
           apply (simp_all add: bunch_of_lemmata_about_matches(1))
       apply(auto simp add: primitive_matcher_generic.Extra_single primitive_matcher_generic.Extra_single_not split: if_split_asm)
     done
  
  private lemma abstract_primitive_in_doubt_deny_Allow2: 
    "primitive_matcher_generic β  normalized_nnf_match m  
      ¬ matches (β, in_doubt_deny) (abstract_primitive disc m) action.Drop p 
      ¬ matches (β, in_doubt_deny) m action.Drop p"
     apply(induction disc m rule: abstract_primitive.induct)
           apply (simp_all add: bunch_of_lemmata_about_matches(1))
       apply(auto simp add: primitive_matcher_generic.Extra_single primitive_matcher_generic.Extra_single_not split: if_split_asm)
     done

  theorem abstract_primitive_in_doubt_deny_generic:
    fixes β::"('i::len common_primitive, ('i, 'a) tagged_packet_scheme) exact_match_tac"
    assumes generic: "primitive_matcher_generic β"
        and n: " r  set rs. normalized_nnf_match (get_match r)"
        and simple: "simple_ruleset rs"
    defines "γ  (β, in_doubt_deny)" and "abstract disc  optimize_matches (abstract_primitive disc)"
    shows   "{p. γ,p abstract disc rs, Undecided α Decision FinalAllow}  {p. γ,p rs, Undecided α Decision FinalAllow}"
             (is ?allow)
    and     "{p. γ,p rs, Undecided α Decision FinalDeny}  {p. γ,p abstract disc rs, Undecided α Decision FinalDeny}"
             (is ?deny)
    proof -
      from simple have "good_ruleset rs" using simple_imp_good_ruleset by fast
      from optimize_matches_simple_ruleset simple simple_imp_good_ruleset have
        good: "good_ruleset (optimize_matches (abstract_primitive disc) rs)" by fast

      let ="(β, in_doubt_deny) :: ('i::len common_primitive, ('i, 'a) tagged_packet_scheme) match_tac"
        ― ‹type signature is needed, otherwise @{const in_doubt_allow} would be for arbitrary packet›
      
      have abstract_primitive_in_doubt_deny_help1:
        "approximating_bigstep_fun γ p (optimize_matches (abstract_primitive disc) rs) Undecided = Decision FinalDeny"
        if prem: "approximating_bigstep_fun γ p rs Undecided = Decision FinalDeny" for p
        proof -
          from simple have "wf_ruleset γ p rs" using good_imp_wf_ruleset simple_imp_good_ruleset by fast
          from this simple prem n show ?thesis
            unfolding γ_def
            proof(induction  p rs Undecided rule: approximating_bigstep_fun_induct_wf)
            case (MatchDrop p m a rs)
              from MatchDrop.prems abstract_primitive_in_doubt_deny_Deny[OF generic] MatchDrop.hyps have
                "matches  (abstract_primitive disc m) action.Drop p" by simp
              thus ?case 
              apply(simp add: MatchDrop.hyps(2))
              using optimize_matches_matches_fst by fastforce
            next
            case (Nomatch p m a rs) thus ?case
              proof(cases "matches  (abstract_primitive disc m) a p")
                case False with Nomatch show ?thesis
                  apply(simp add: optimize_matches_def)
                  using simple_ruleset_tail by blast
                next
                case True
                  from Nomatch.prems(1) have "a = action.Accept  a = action.Drop" by(simp add: simple_ruleset_def)
                  from Nomatch.hyps(1) Nomatch.prems(3) abstract_primitive_in_doubt_deny_Deny2[OF generic] have
                    "a = action.Accept  ¬ matches  (abstract_primitive disc m) action.Accept p" by(simp)
                  with True a = action.Accept  a = action.Drop› have "a = action.Drop" by blast
                  with True show ?thesis using optimize_matches_matches_fst by fastforce
                qed
            qed(simp_all add: simple_ruleset_def)
      qed

      have abstract_primitive_in_doubt_deny_help2:
        "approximating_bigstep_fun γ p rs Undecided = Decision FinalAllow"
        if prem: "approximating_bigstep_fun γ p (optimize_matches (abstract_primitive disc) rs) Undecided = Decision FinalAllow"
        for p
        proof -
          from simple have "wf_ruleset  p rs" using good_imp_wf_ruleset simple_imp_good_ruleset by fast
          from this simple prem n show ?thesis
            unfolding γ_def
            proof(induction  p rs Undecided rule: approximating_bigstep_fun_induct_wf)
            case Empty thus ?case by(simp add: optimize_matches_def)
            next
            case (MatchAccept p m a rs) thus ?case by auto
            next
            case (MatchDrop p m a rs)
              from MatchDrop.prems abstract_primitive_in_doubt_deny_Deny[OF generic] MatchDrop.hyps have
                1: "matches  (abstract_primitive disc m) action.Drop p" by simp
              from MatchDrop have "approximating_bigstep_fun  p
                (Rule (abstract_primitive disc m) action.Drop # (optimize_matches (abstract_primitive disc) rs)) Undecided = Decision FinalAllow"
              using optimize_matches_matches_fst 1 by fastforce
              with 1 have False by(simp)
              thus ?case ..
            next
            case (Nomatch p m a rs) thus ?case
              proof(cases "matches  (abstract_primitive disc m) a p")
                case False 
                with Nomatch.prems(2) have "approximating_bigstep_fun  p (optimize_matches (abstract_primitive disc) rs) Undecided = Decision FinalAllow"
                  by(simp add: optimize_matches_def split: if_split_asm)
                with Nomatch have IH: "approximating_bigstep_fun  p rs Undecided = Decision FinalAllow"
                  using simple_ruleset_tail by auto
                with Nomatch(1) show ?thesis by simp
                next
                case True
                  from Nomatch.prems(2) True have 1: "approximating_bigstep_fun  p
                    (Rule (abstract_primitive disc m) a # (optimize_matches (abstract_primitive disc) rs)) Undecided = Decision FinalAllow"
                    using optimize_matches_matches_fst by metis
                  from Nomatch.prems(1) have "a = action.Accept  a = action.Drop" by(simp add: simple_ruleset_def)
                  from Nomatch.hyps(1) Nomatch.prems(3) abstract_primitive_in_doubt_deny_Deny2[OF generic] have
                    "a = action.Accept  ¬ matches  (abstract_primitive disc m) action.Accept p" by simp
                  with True a = action.Accept  a = action.Drop› have "a = action.Drop" by blast
                  with 1 True have False by force
                  thus ?thesis ..
                qed
            qed(simp_all add: simple_ruleset_def)
      qed

      from good approximating_semantics_iff_fun_good_ruleset abstract_primitive_in_doubt_deny_help1 ‹good_ruleset rs show ?deny
        unfolding abstract_def by fast
      from good approximating_semantics_iff_fun_good_ruleset abstract_primitive_in_doubt_deny_help2 ‹good_ruleset rs show ?allow
        unfolding abstract_def by fast
    qed
end



end

Theory SimpleFw_Compliance

section‹Iptables to Simple Firewall and Vice Versa›
theory SimpleFw_Compliance
imports Simple_Firewall.SimpleFw_Semantics
        "../Primitive_Matchers/Transform"
        "../Primitive_Matchers/Primitive_Abstract"
begin

subsection‹Simple Match to MatchExpr›

fun simple_match_to_ipportiface_match :: "'i::len simple_match  'i common_primitive match_expr" where
  "simple_match_to_ipportiface_match iiface=iif, oiface=oif, src=sip, dst=dip, proto=p, sports=sps, dports=dps  =
    MatchAnd (Match (IIface iif)) (MatchAnd (Match (OIface oif)) 
    (MatchAnd (Match (Src (uncurry IpAddrNetmask sip)))
    (MatchAnd (Match (Dst (uncurry IpAddrNetmask dip)))
    (case p of ProtoAny  MatchAny
            |  Proto prim_p  
                (MatchAnd (Match (Prot p))
                (MatchAnd (Match (Src_Ports (L4Ports prim_p [sps])))
                (Match (Dst_Ports (L4Ports prim_p [dps])))
                ))
    ))))"

lemma ports_to_set_singleton_simple_match_port: "p  ports_to_set [a]  simple_match_port a p"
  by(cases a, simp)

theorem simple_match_to_ipportiface_match_correct:
  assumes valid: "simple_match_valid sm"
  shows "matches (common_matcher, α) (simple_match_to_ipportiface_match sm) a p  simple_matches sm p"
  proof -
  obtain iif oif sip dip pro sps dps where
    sm: "sm = iiface = iif, oiface = oif, src = sip, dst = dip, proto = pro, sports = sps, dports = dps" by (cases sm)
  { fix ip
    have "p_src p  ipt_iprange_to_set (uncurry IpAddrNetmask ip)  simple_match_ip ip (p_src p)"
    and  "p_dst p  ipt_iprange_to_set (uncurry IpAddrNetmask ip)  simple_match_ip ip (p_dst p)"
     by(simp split: uncurry_split)+
  } note simple_match_ips=this
  { fix ps
    have "p_sport p  ports_to_set [ps]  simple_match_port ps (p_sport p)"
    and  "p_dport p  ports_to_set [ps]  simple_match_port ps (p_dport p)"
      apply(case_tac [!] ps)
      by(simp_all)
  } note simple_match_ports=this
  from valid sm have valid':"pro = ProtoAny  simple_match_port sps (p_sport p)  simple_match_port dps (p_dport p)"
    apply(simp add: simple_match_valid_def)
    by blast
  show ?thesis unfolding sm
  apply(cases pro)
   subgoal
   apply(simp add: bunch_of_lemmata_about_matches simple_matches.simps)
   apply(simp add: match_raw_bool ternary_to_bool_bool_to_ternary simple_match_ips simple_match_ports simple_matches.simps)
   using valid' by simp
  apply(simp add: bunch_of_lemmata_about_matches simple_matches.simps)
  apply(simp add: match_raw_bool ternary_to_bool_bool_to_ternary simple_match_ips simple_match_ports simple_matches.simps)
  apply fast
  done
qed



subsection‹MatchExpr to Simple Match›

fun common_primitive_match_to_simple_match :: "'i::len common_primitive match_expr  'i simple_match option" where
  "common_primitive_match_to_simple_match MatchAny = Some (simple_match_any)" |
  "common_primitive_match_to_simple_match (MatchNot MatchAny) = None" |
  "common_primitive_match_to_simple_match (Match (IIface iif)) = Some (simple_match_any iiface := iif )" |
  "common_primitive_match_to_simple_match (Match (OIface oif)) = Some (simple_match_any oiface := oif )" |
  "common_primitive_match_to_simple_match (Match (Src (IpAddrNetmask pre len))) = Some (simple_match_any src := (pre, len) )" |
  "common_primitive_match_to_simple_match (Match (Dst (IpAddrNetmask pre len))) = Some (simple_match_any dst := (pre, len) )" |
  "common_primitive_match_to_simple_match (Match (Prot p)) = Some (simple_match_any proto := p )" |
  "common_primitive_match_to_simple_match (Match (Src_Ports (L4Ports p []))) = None" |
  "common_primitive_match_to_simple_match (Match (Src_Ports (L4Ports p [(s,e)]))) = Some (simple_match_any proto := Proto p, sports := (s,e) )" |
  "common_primitive_match_to_simple_match (Match (Dst_Ports (L4Ports p []))) = None" |
  "common_primitive_match_to_simple_match (Match (Dst_Ports (L4Ports p [(s,e)]))) = Some (simple_match_any proto := Proto p, dports := (s,e) )" |
  "common_primitive_match_to_simple_match (MatchNot (Match (Prot ProtoAny))) = None" |
  "common_primitive_match_to_simple_match (MatchAnd m1 m2) = (case (common_primitive_match_to_simple_match m1, common_primitive_match_to_simple_match m2) of 
      (None, _)  None
    | (_, None)  None
    | (Some m1', Some m2')  simple_match_and m1' m2')" |
  ― ‹undefined cases, normalize before!›
  "common_primitive_match_to_simple_match (Match (Src (IpAddr _))) = undefined" |
  "common_primitive_match_to_simple_match (Match (Src (IpAddrRange _ _))) = undefined" |
  "common_primitive_match_to_simple_match (Match (Dst (IpAddr _))) = undefined" |
  "common_primitive_match_to_simple_match (Match (Dst (IpAddrRange _ _))) = undefined" |
  "common_primitive_match_to_simple_match (MatchNot (Match (Prot _))) = undefined" |
  "common_primitive_match_to_simple_match (MatchNot (Match (IIface _))) = undefined" |
  "common_primitive_match_to_simple_match (MatchNot (Match (OIface _))) = undefined" |
  "common_primitive_match_to_simple_match (MatchNot (Match (Src _))) = undefined" |
  "common_primitive_match_to_simple_match (MatchNot (Match (Dst _))) = undefined" |
  "common_primitive_match_to_simple_match (MatchNot (MatchAnd _ _)) = undefined" |
  "common_primitive_match_to_simple_match (MatchNot (MatchNot _)) = undefined" |
  "common_primitive_match_to_simple_match (Match (Src_Ports _)) = undefined" |
  "common_primitive_match_to_simple_match (Match (Dst_Ports _)) = undefined" |
  "common_primitive_match_to_simple_match (MatchNot (Match (Src_Ports _))) = undefined" |
  "common_primitive_match_to_simple_match (MatchNot (Match (Dst_Ports _))) = undefined" |
  "common_primitive_match_to_simple_match (Match (CT_State _)) = undefined" |
  "common_primitive_match_to_simple_match (Match (L4_Flags _)) = undefined" |
  "common_primitive_match_to_simple_match (MatchNot (Match (L4_Flags _))) = undefined" |
  "common_primitive_match_to_simple_match (Match (Extra _)) = undefined" |
  "common_primitive_match_to_simple_match (MatchNot (Match (Extra _))) = undefined" |
  "common_primitive_match_to_simple_match (MatchNot (Match (CT_State _))) = undefined"



subsubsection‹Normalizing Interfaces›
text‹As for now, negated interfaces are simply not allowed›
  definition normalized_ifaces :: "'i::len common_primitive match_expr  bool" where
    "normalized_ifaces m  ¬ has_disc_negated (λa. is_Iiface a  is_Oiface a) False m"

subsubsection‹Normalizing Protocols›
text‹As for now, negated protocols are simply not allowed›
  definition normalized_protocols :: "'i::len common_primitive match_expr  bool" where
    "normalized_protocols m  ¬ has_disc_negated is_Prot False m"



lemma match_iface_simple_match_any_simps:
     "match_iface (iiface simple_match_any) (p_iiface p)"
     "match_iface (oiface simple_match_any) (p_oiface p)"
     "simple_match_ip (src simple_match_any) (p_src p)"
     "simple_match_ip (dst simple_match_any) (p_dst p)"
     "match_proto (proto simple_match_any) (p_proto p)"
     "simple_match_port (sports simple_match_any) (p_sport p)"
     "simple_match_port (dports simple_match_any) (p_dport p)"
        apply (simp_all add: simple_match_any_def match_ifaceAny ipset_from_cidr_0)
   apply (subgoal_tac [!] "(65535::16 word) = max_word")
     apply (simp_all only:)
     apply simp_all
  done

theorem common_primitive_match_to_simple_match:
  assumes "normalized_src_ports m" 
      and "normalized_dst_ports m"
      and "normalized_src_ips m"
      and "normalized_dst_ips m"
      and "normalized_ifaces m"
      and "normalized_protocols m"
      and "¬ has_disc is_L4_Flags m"
      and "¬ has_disc is_CT_State m"
      and "¬ has_disc is_MultiportPorts m"
      and "¬ has_disc is_Extra m"
  shows "(Some sm = common_primitive_match_to_simple_match m  matches (common_matcher, α) m a p  simple_matches sm p) 
         (common_primitive_match_to_simple_match m = None  ¬ matches (common_matcher, α) m a p)"
proof -
  show ?thesis
  using assms proof(induction m arbitrary: sm rule: common_primitive_match_to_simple_match.induct)
  case 1 thus ?case 
    by(simp add: match_iface_simple_match_any_simps bunch_of_lemmata_about_matches simple_matches.simps)
  next
  case (9 p s e) thus ?case
    apply(simp add: match_iface_simple_match_any_simps simple_matches.simps)
    apply(simp add: match_raw_bool ternary_to_bool_bool_to_ternary)
    by fastforce
  next
  case 11 thus ?case 
    apply(simp add: match_iface_simple_match_any_simps simple_matches.simps)
    apply(simp add: match_raw_bool ternary_to_bool_bool_to_ternary)
    by fastforce
  next
  case (13 m1 m2)
    let ?caseSome="Some sm = common_primitive_match_to_simple_match (MatchAnd m1 m2)"
    let ?caseNone="common_primitive_match_to_simple_match (MatchAnd m1 m2) = None"
    let ?goal="(?caseSome  matches (common_matcher, α) (MatchAnd m1 m2) a p = simple_matches sm p)  
               (?caseNone  ¬ matches (common_matcher, α) (MatchAnd m1 m2) a p)"

    from 13 have normalized:
      "normalized_src_ports m1" "normalized_src_ports m2"
      "normalized_dst_ports m1" "normalized_dst_ports m2"
      "normalized_src_ips m1" "normalized_src_ips m2"
      "normalized_dst_ips m1" "normalized_dst_ips m2"
      "normalized_ifaces m1" "normalized_ifaces m2"
      "¬ has_disc is_L4_Flags m1" "¬ has_disc is_L4_Flags m2"
      "¬ has_disc is_CT_State m1" "¬ has_disc is_CT_State m2"
      "¬ has_disc is_MultiportPorts m1" "¬ has_disc is_MultiportPorts m2"
      "¬ has_disc is_Extra m1" "¬ has_disc is_Extra m2"
      "normalized_protocols m1" "normalized_protocols m2"
      by(simp_all add: normalized_protocols_def normalized_ifaces_def)
    {  assume caseNone: ?caseNone
      { fix sm1 sm2
        assume sm1: "common_primitive_match_to_simple_match m1 = Some sm1"
           and sm2: "common_primitive_match_to_simple_match m2 = Some sm2"
           and sma: "simple_match_and sm1 sm2 = None"
        from sma have 1: "¬ (simple_matches sm1 p  simple_matches sm2 p)" by (simp add: simple_match_and_correct)
        from normalized sm1 sm2 "13.IH" have 2: "(matches (common_matcher, α) m1 a p  simple_matches sm1 p)  
                              (matches (common_matcher, α) m2 a p  simple_matches sm2 p)" by force
        hence 2: "matches (common_matcher, α) (MatchAnd m1 m2) a p  simple_matches sm1 p  simple_matches sm2 p"
          by(simp add: bunch_of_lemmata_about_matches)
        from 1 2 have "¬ matches (common_matcher, α) (MatchAnd m1 m2) a p" by blast 
      }
      with caseNone have "common_primitive_match_to_simple_match m1 = None 
                          common_primitive_match_to_simple_match m2 = None 
                          ¬ matches (common_matcher, α) (MatchAnd m1 m2) a p"
        by(simp split:option.split_asm)
      hence "¬ matches (common_matcher, α) (MatchAnd m1 m2) a p" 
        apply(elim disjE)
          apply(simp_all)
         using "13.IH" normalized by(simp add: bunch_of_lemmata_about_matches)+
    }note caseNone=this

    { assume caseSome: ?caseSome
      hence " sm1. common_primitive_match_to_simple_match m1 = Some sm1" and
            " sm2. common_primitive_match_to_simple_match m2 = Some sm2"
        by(simp_all split: option.split_asm)
      from this obtain sm1 sm2 where sm1: "Some sm1 = common_primitive_match_to_simple_match m1"
                                 and sm2: "Some sm2 = common_primitive_match_to_simple_match m2" by fastforce+
      with "13.IH" normalized have "matches (common_matcher, α) m1 a p = simple_matches sm1 p 
                    matches (common_matcher, α) m2 a p = simple_matches sm2 p" by simp
      hence 1: "matches (common_matcher, α) (MatchAnd m1 m2) a p  simple_matches sm1 p  simple_matches sm2 p"
        by(simp add: bunch_of_lemmata_about_matches)
      from caseSome sm1 sm2 have "simple_match_and sm1 sm2 = Some sm" by(simp split: option.split_asm)
      hence 2: "simple_matches sm p  simple_matches sm1 p  simple_matches sm2 p" by(simp add: simple_match_and_correct)
      from 1 2 have "matches (common_matcher, α) (MatchAnd m1 m2) a p = simple_matches sm p" by simp
    } note caseSome=this

    from caseNone caseSome show ?goal by blast
  qed(simp_all add: match_iface_simple_match_any_simps simple_matches.simps normalized_protocols_def normalized_ifaces_def, 
      simp_all add: bunch_of_lemmata_about_matches, 
      simp_all add: match_raw_bool ternary_to_bool_bool_to_ternary)
qed

lemma simple_fw_remdups_Rev: "simple_fw (remdups_rev rs) p = simple_fw rs p"
  apply(induction rs p rule: simple_fw.induct)
    apply(simp add: remdups_rev_def)
   apply(simp_all add: remdups_rev_fst remdups_rev_removeAll simple_fw_not_matches_removeAll)
  done

fun action_to_simple_action :: "action  simple_action" where
  "action_to_simple_action action.Accept = simple_action.Accept" |
  "action_to_simple_action action.Drop   = simple_action.Drop" |
  "action_to_simple_action _ = undefined"

definition check_simple_fw_preconditions :: "'i::len common_primitive rule list  bool" where
  "check_simple_fw_preconditions rs  r  set rs. (case r of (Rule m a) 
      normalized_src_ports m 
      normalized_dst_ports m 
      normalized_src_ips m 
      normalized_dst_ips m 
      normalized_ifaces m  
      normalized_protocols m 
      ¬ has_disc is_L4_Flags m 
      ¬ has_disc is_CT_State m 
      ¬ has_disc is_MultiportPorts m 
      ¬ has_disc is_Extra m 
      (a = action.Accept  a = action.Drop))"


(*apart from MatchNot MatchAny, the normalizations imply nnf*)
lemma "normalized_src_ports m  normalized_nnf_match m"
  apply(induction m rule: normalized_src_ports.induct)
  apply(simp_all)[15]
  oops
lemma "¬ matcheq_matchNone m  normalized_src_ports m  normalized_nnf_match m"
  by(induction m rule: normalized_src_ports.induct) (simp_all)

value "check_simple_fw_preconditions [Rule (MatchNot (MatchNot (MatchNot (Match (Src a))))) action.Accept]"


definition to_simple_firewall :: "'i::len common_primitive rule list  'i simple_rule list" where
  "to_simple_firewall rs  if check_simple_fw_preconditions rs then
      List.map_filter (λr. case r of Rule m a  
        (case (common_primitive_match_to_simple_match m) of None  None |
                    Some sm  Some (SimpleRule sm (action_to_simple_action a)))) rs
    else undefined"

lemma to_simple_firewall_simps:
      "to_simple_firewall [] = []"
      "check_simple_fw_preconditions ((Rule m a)#rs)  to_simple_firewall ((Rule m a)#rs) = (case common_primitive_match_to_simple_match m of
          None  to_simple_firewall rs
          | Some sm  (SimpleRule sm (action_to_simple_action a)) # to_simple_firewall rs)"
      "¬ check_simple_fw_preconditions rs'  to_simple_firewall rs' = undefined"
   by(auto simp add: to_simple_firewall_def List.map_filter_simps check_simple_fw_preconditions_def split: option.split)


lemma "check_simple_fw_preconditions
     [Rule (MatchAnd (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (127, 0, 0, 0)) 8)))
                          (MatchAnd (Match (Dst_Ports (L4Ports TCP [(0, 65535)])))
                                    (Match (Src_Ports (L4Ports TCP [(0, 65535)])))))
                Drop]" by eval
lemma "to_simple_firewall
     [Rule (MatchAnd (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (127, 0, 0, 0)) 8)))
                          (MatchAnd (Match (Dst_Ports (L4Ports TCP [(0, 65535)])))
                                    (Match (Src_Ports (L4Ports TCP [(0, 65535)])))))
                Drop] =
[SimpleRule
   iiface = Iface ''+'', oiface = Iface ''+'', src = (0x7F000000, 8), dst = (0, 0), proto = Proto 6, sports = (0, 0xFFFF),
      dports = (0, 0xFFFF)
   simple_action.Drop]" by eval
lemma "check_simple_fw_preconditions [Rule (MatchAnd MatchAny MatchAny) Drop]"
  by(simp add: check_simple_fw_preconditions_def normalized_ifaces_def normalized_protocols_def)
lemma "to_simple_firewall [Rule (MatchAnd MatchAny (MatchAny::32 common_primitive match_expr)) Drop] =
  [SimpleRule
   iiface = Iface ''+'', oiface = Iface ''+'', src = (0, 0), dst = (0, 0), proto = ProtoAny, sports = (0, 0xFFFF),
      dports = (0, 0xFFFF)
   simple_action.Drop]" by eval
lemma "to_simple_firewall [Rule (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (127, 0, 0, 0)) 8))) Drop] =
[SimpleRule
   iiface = Iface ''+'', oiface = Iface ''+'', src = (0x7F000000, 8), dst = (0, 0), proto = ProtoAny, sports = (0, 0xFFFF),
      dports = (0, 0xFFFF)
   simple_action.Drop]" by eval



theorem to_simple_firewall: "check_simple_fw_preconditions rs  approximating_bigstep_fun (common_matcher, α) p rs Undecided = simple_fw (to_simple_firewall rs) p"
  proof(induction rs)
  case Nil thus ?case by(simp add: to_simple_firewall_simps)
  next
  case (Cons r rs)
    from Cons have IH: "approximating_bigstep_fun (common_matcher, α) p rs Undecided = simple_fw (to_simple_firewall rs) p"
    by(simp add: check_simple_fw_preconditions_def)
    obtain m a where r: "r = Rule m a" by(cases r, simp)
    from Cons.prems have "check_simple_fw_preconditions [r]" by(simp add: check_simple_fw_preconditions_def)
    with r common_primitive_match_to_simple_match[where p = p]
    have match: " sm. common_primitive_match_to_simple_match m = Some sm  matches (common_matcher, α) m a p = simple_matches sm p" and
         nomatch: "common_primitive_match_to_simple_match m = None  ¬ matches (common_matcher, α) m a p"
      unfolding check_simple_fw_preconditions_def by simp_all
    from to_simple_firewall_simps r Cons.prems have to_simple_firewall_simps': "to_simple_firewall (Rule m a # rs) =
        (case common_primitive_match_to_simple_match m of None  to_simple_firewall rs
                       | Some sm  SimpleRule sm (action_to_simple_action a) # to_simple_firewall rs)" by simp
    from ‹check_simple_fw_preconditions [r] have "a = action.Accept  a = action.Drop" by(simp add: r check_simple_fw_preconditions_def)
    thus ?case
      by(auto simp add: r to_simple_firewall_simps' IH match nomatch split: option.split action.split)
  qed


lemma ctstate_assume_new_not_has_CT_State:
  "r  set (ctstate_assume_new rs)  ¬ has_disc is_CT_State (get_match r)"
  apply(simp add: ctstate_assume_new_def)
  apply(induction rs)
   apply(simp add: optimize_matches_def; fail)
  apply(simp add: optimize_matches_def)
  apply(rename_tac r' rs, case_tac r')
  apply(safe)
  apply(simp add:  split:if_split_asm)
  apply(elim disjE)
   apply(simp_all add: not_hasdisc_ctstate_assume_state split:if_split_asm)
  done

  

text‹The precondition for the simple firewall can be easily fulfilled.
      The subset relation is due to abstracting over some primitives (e.g., negated primitives, l4 flags)›
theorem transform_simple_fw_upper:
  defines "preprocess rs  upper_closure (optimize_matches abstract_for_simple_firewall (upper_closure (packet_assume_new rs)))"
  and "newpkt p  match_tcp_flags ipt_tcp_syn (p_tcp_flags p)  p_tag_ctstate p = CT_New"
  assumes simplers: "simple_ruleset (rs:: 'i::len common_primitive rule list)"
  ― ‹the preconditions for the simple firewall are fulfilled, definitely no runtime failure›
  shows "check_simple_fw_preconditions (preprocess rs)"
  ― ‹the set of new packets, which are accepted is an overapproximations›
  and "{p. (common_matcher, in_doubt_allow),p rs, Undecided α Decision FinalAllow  newpkt p} 
       {p. simple_fw (to_simple_firewall (preprocess rs)) p = Decision FinalAllow  newpkt p}"
  ― ‹Fun fact: The theorem holds for a tagged packet. The simple firewall just ignores the tag. 
     You may explicitly untag, if you wish to, but a @{typ "'i tagged_packet"} is just an extension of the
     @{typ "'i simple_packet"} used by the simple firewall›
  unfolding check_simple_fw_preconditions_def preprocess_def
  apply(clarify, rename_tac r, case_tac r, rename_tac m a, simp)
  proof -
    let ?rs2="upper_closure (packet_assume_new rs)"
    let ?rs3="optimize_matches abstract_for_simple_firewall ?rs2"
    let ?rs'="upper_closure ?rs3"
    let ="(common_matcher, in_doubt_allow)
            :: ('i::len common_primitive, ('i, 'a) tagged_packet_scheme) match_tac"
    let ?fw="λrs p. approximating_bigstep_fun  p rs Undecided"

    from packet_assume_new_simple_ruleset[OF simplers] have s1: "simple_ruleset (packet_assume_new rs)" .
    from transform_upper_closure(2)[OF s1] have s2: "simple_ruleset ?rs2" .
    from s2 have s3: "simple_ruleset ?rs3" by (simp add: optimize_matches_simple_ruleset) 
    from transform_upper_closure(2)[OF s3] have s4: "simple_ruleset ?rs'" .

    from transform_upper_closure(3)[OF s1] have nnf2:
      "rset (upper_closure (packet_assume_new rs)). normalized_nnf_match (get_match r)" by simp
    
  { fix m a
    assume r: "Rule m a  set ?rs'"

    from s4 r have a: "(a = action.Accept  a = action.Drop)" by(auto simp add: simple_ruleset_def)
    
    have "r  set (packet_assume_new rs)  ¬ has_disc is_CT_State (get_match r)" for r
      by(simp add: packet_assume_new_def ctstate_assume_new_not_has_CT_State)
    with transform_upper_closure(4)[OF s1, where disc=is_CT_State] have
      "rset (upper_closure (packet_assume_new rs)). ¬ has_disc is_CT_State (get_match r)"
      by simp
    with abstract_primitive_preserves_nodisc[where disc'="is_CT_State"]
    have "rset ?rs3. ¬ has_disc is_CT_State (get_match r)"
      apply(intro optimize_matches_preserves)
      by(auto simp add: abstract_for_simple_firewall_def)
    with transform_upper_closure(4)[OF s3, where disc=is_CT_State] have
      "rset ?rs'. ¬ has_disc is_CT_State (get_match r)" by simp
    with r have no_CT: "¬ has_disc is_CT_State m" by fastforce

    from abstract_for_simple_firewall_hasdisc have "rset ?rs3. ¬ has_disc is_L4_Flags (get_match r)"
      by(intro optimize_matches_preserves, auto)
    with transform_upper_closure(4)[OF s3, where disc=is_L4_Flags] have
      "rset ?rs'. ¬ has_disc is_L4_Flags (get_match r)" by simp
    with r have no_L4_Flags: "¬ has_disc is_L4_Flags m" by fastforce

    from nnf2 abstract_for_simple_firewall_negated_ifaces_prots have
      ifaces: "rset ?rs3. ¬ has_disc_negated (λa. is_Iiface a  is_Oiface a) False (get_match r)" and
      protocols_rs3: "rset ?rs3. ¬ has_disc_negated is_Prot False (get_match r)" 
      by(intro optimize_matches_preserves, blast)+
    from ifaces have iface_in:  "rset ?rs3. ¬ has_disc_negated is_Iiface False (get_match r)" and
                     iface_out: "rset ?rs3. ¬ has_disc_negated is_Oiface False (get_match r)"
    using has_disc_negated_disj_split by blast+

    from transform_upper_closure(3)[OF s3] have "rset ?rs'.
     normalized_nnf_match (get_match r)  normalized_src_ports (get_match r) 
     normalized_dst_ports (get_match r)  normalized_src_ips (get_match r) 
     normalized_dst_ips (get_match r)  
     ¬ has_disc is_MultiportPorts (get_match r)  ¬ has_disc is_Extra (get_match r)" .
    with r have normalized:
      "normalized_src_ports m  normalized_dst_ports m 
      normalized_src_ips m  normalized_dst_ips m  
      ¬ has_disc is_MultiportPorts m & ¬ has_disc is_Extra m" by fastforce

    (*things are complicated because upper closure could introduce negated protocols.
      should not happen if we don't have negated ports in it *)
    from transform_upper_closure(5)[OF s3] iface_in iface_out have "rset ?rs'.
     ¬ has_disc_negated is_Iiface False (get_match r)  ¬ has_disc_negated is_Oiface False (get_match r)" by simp (*500ms*)
    with r have abstracted_ifaces: "normalized_ifaces m"
    unfolding normalized_ifaces_def has_disc_negated_disj_split by fastforce

    from transform_upper_closure(3)[OF s1]
      normalized_n_primitive_imp_not_disc_negated[OF wf_disc_sel_common_primitive(1)]
      normalized_n_primitive_imp_not_disc_negated[OF wf_disc_sel_common_primitive(2)]
    have "r set ?rs2. ¬ has_disc_negated is_Src_Ports False (get_match r) 
                        ¬ has_disc_negated is_Dst_Ports False (get_match r) 
                        ¬ has_disc is_MultiportPorts (get_match r)"
      apply(simp add: normalized_src_ports_def2 normalized_dst_ports_def2)
      by blast 
    from this have "rset ?rs3. ¬ has_disc_negated is_Src_Ports False (get_match r) 
                                 ¬ has_disc_negated is_Dst_Ports False (get_match r) 
                                 ¬ has_disc is_MultiportPorts (get_match r)"
      apply -
      apply(rule optimize_matches_preserves)
      apply(intro conjI)
        apply(intro abstract_for_simple_firewall_preserves_nodisc_negated, simp_all)+
      by (simp add: abstract_for_simple_firewall_def abstract_primitive_preserves_nodisc)

    from this protocols_rs3 transform_upper_closure(5)[OF s3, where disc=is_Prot, simplified]
          have "rset ?rs'. ¬ has_disc_negated is_Prot False (get_match r)"
      by simp
    with r have abstracted_prots: "normalized_protocols m"
    unfolding normalized_protocols_def has_disc_negated_disj_split by fastforce
    
    from no_CT no_L4_Flags s4 normalized a abstracted_ifaces abstracted_prots show "normalized_src_ports m 
             normalized_dst_ports m 
             normalized_src_ips m 
             normalized_dst_ips m 
             normalized_ifaces m 
             normalized_protocols m 
             ¬ has_disc is_L4_Flags m 
             ¬ has_disc is_CT_State m 
             ¬ has_disc is_MultiportPorts m 
             ¬ has_disc is_Extra m  (a = action.Accept  a = action.Drop)"
      by(simp)
  }
    hence simple_fw_preconditions: "check_simple_fw_preconditions ?rs'"
    unfolding check_simple_fw_preconditions_def
    by(clarify, rename_tac r, case_tac r, rename_tac m a, simp)


    have 1: "{p. ,p ?rs', Undecided α Decision FinalAllow  newpkt p} =
          {p. ,p ?rs3, Undecided α Decision FinalAllow  newpkt p}"
      apply(subst transform_upper_closure(1)[OF s3])
      by simp
    from abstract_primitive_in_doubt_allow_generic(2)[OF primitive_matcher_generic_common_matcher nnf2 s2] have 2:
         "{p. ,p upper_closure (packet_assume_new rs), Undecided α Decision FinalAllow  newpkt p} 
          {p. ,p ?rs3, Undecided α Decision FinalAllow  newpkt p}"
      by(auto simp add: abstract_for_simple_firewall_def)
    have 3: "{p. ,p upper_closure (packet_assume_new rs), Undecided α Decision FinalAllow  newpkt p} =
          {p. ,p rs, Undecided α Decision FinalAllow  newpkt p}"
      apply(subst transform_upper_closure(1)[OF s1])
      apply(subst approximating_semantics_iff_fun_good_ruleset[OF simple_imp_good_ruleset[OF s1]])
      apply(subst approximating_semantics_iff_fun_good_ruleset[OF simple_imp_good_ruleset[OF simplers]])
      using packet_assume_new newpkt_def by fastforce
      
    have 4: "p. ,p ?rs', Undecided α Decision FinalAllow  ?fw ?rs' p = Decision FinalAllow"
      using approximating_semantics_iff_fun_good_ruleset[OF simple_imp_good_ruleset[OF s4]] by fast
    
    have "{p. ,p rs, Undecided α Decision FinalAllow  newpkt p} 
       {p. ,p ?rs', Undecided α Decision FinalAllow  newpkt p}"
      apply(subst 1)
      apply(subst 3[symmetric])
      using 2 by blast
    
    thus "{p. ,p rs, Undecided α Decision FinalAllow  newpkt p} 
       {p. simple_fw (to_simple_firewall ?rs') p = Decision FinalAllow  newpkt p}"
       apply safe
       subgoal for p using to_simple_firewall[OF simple_fw_preconditions, where p = p] 4 by auto
      done
  qed


(*Copy&paste from transform_simple_fw_upper*)
theorem transform_simple_fw_lower:
  defines "preprocess rs  lower_closure (optimize_matches abstract_for_simple_firewall (lower_closure (packet_assume_new rs)))"
  and "newpkt p  match_tcp_flags ipt_tcp_syn (p_tcp_flags p)  p_tag_ctstate p = CT_New"
  assumes simplers: "simple_ruleset (rs:: 'i::len common_primitive rule list)"
  ― ‹the preconditions for the simple firewall are fulfilled, definitely no runtime failure›
  shows "check_simple_fw_preconditions (preprocess rs)"
  ― ‹the set of new packets, which are accepted is an underapproximation›
  and "{p. simple_fw (to_simple_firewall (preprocess rs)) p = Decision FinalAllow  newpkt p} 
       {p. (common_matcher, in_doubt_deny),p rs, Undecided α Decision FinalAllow  newpkt p}"
  unfolding check_simple_fw_preconditions_def preprocess_def
  apply(clarify, rename_tac r, case_tac r, rename_tac m a, simp)
  proof -
    let ?rs2="lower_closure (packet_assume_new rs)"
    let ?rs3="optimize_matches abstract_for_simple_firewall ?rs2"
    let ?rs'="lower_closure ?rs3"
    let ="(common_matcher, in_doubt_deny)
            :: ('i::len common_primitive, ('i, 'a) tagged_packet_scheme) match_tac"
    let ?fw="λrs p. approximating_bigstep_fun  p rs Undecided"

    from packet_assume_new_simple_ruleset[OF simplers] have s1: "simple_ruleset (packet_assume_new rs)" .
    from transform_lower_closure(2)[OF s1] have s2: "simple_ruleset (lower_closure (packet_assume_new rs))" .
    from s2 have s3: "simple_ruleset ?rs3" by (simp add: optimize_matches_simple_ruleset) 
    from transform_lower_closure(2)[OF s3] have s4: "simple_ruleset ?rs'" .

    from transform_lower_closure(3)[OF s1] have nnf2:
      "rset (lower_closure (packet_assume_new rs)). normalized_nnf_match (get_match r)" by simp
    
  { fix m a
    assume r: "Rule m a  set ?rs'"

    from s4 r have a: "(a = action.Accept  a = action.Drop)" by(auto simp add: simple_ruleset_def)
    
    have "r  set (packet_assume_new rs)  ¬ has_disc is_CT_State (get_match r)" for r 
      by(simp add: packet_assume_new_def ctstate_assume_new_not_has_CT_State)
    with transform_lower_closure(4)[OF s1, where disc=is_CT_State] have
      "rset (lower_closure (packet_assume_new rs)). ¬ has_disc is_CT_State (get_match r)"
      by fastforce
    with abstract_primitive_preserves_nodisc[where disc'="is_CT_State"] have
      "rset ?rs3. ¬ has_disc is_CT_State (get_match r)"
      apply(intro optimize_matches_preserves)
      by(auto simp add: abstract_for_simple_firewall_def)
    with transform_lower_closure(4)[OF s3, where disc=is_CT_State] have
      "rset ?rs'. ¬ has_disc is_CT_State (get_match r)" by fastforce
    with r have no_CT: "¬ has_disc is_CT_State m" by fastforce

    from abstract_for_simple_firewall_hasdisc have "rset ?rs3. ¬ has_disc is_L4_Flags (get_match r)"
      by(intro optimize_matches_preserves, blast)
    with transform_lower_closure(4)[OF s3, where disc=is_L4_Flags] have
      "rset ?rs'. ¬ has_disc is_L4_Flags (get_match r)" by fastforce
    with r have no_L4_Flags: "¬ has_disc is_L4_Flags m" by fastforce

    from nnf2 abstract_for_simple_firewall_negated_ifaces_prots have
      ifaces: "rset ?rs3. ¬ has_disc_negated (λa. is_Iiface a  is_Oiface a) False (get_match r)" and
      protocols_rs3: "rset ?rs3. ¬ has_disc_negated is_Prot False (get_match r)" 
      by(intro optimize_matches_preserves, blast)+
    from ifaces have iface_in:  "rset ?rs3. ¬ has_disc_negated is_Iiface False (get_match r)" and
                     iface_out: "rset ?rs3. ¬ has_disc_negated is_Oiface False (get_match r)"
    using has_disc_negated_disj_split by blast+

    from transform_lower_closure(3)[OF s3] have "rset ?rs'.
     normalized_nnf_match (get_match r)  normalized_src_ports (get_match r) 
     normalized_dst_ports (get_match r)  normalized_src_ips (get_match r) 
     normalized_dst_ips (get_match r)  
     ¬ has_disc is_MultiportPorts (get_match r)  ¬ has_disc is_Extra (get_match r)" .
    with r have normalized: "normalized_src_ports m  normalized_dst_ports m  normalized_src_ips m 
      normalized_dst_ips m  ¬ has_disc is_MultiportPorts m  ¬ has_disc is_Extra m" by fastforce


    from transform_lower_closure(5)[OF s3] iface_in iface_out have "rset ?rs'.
     ¬ has_disc_negated is_Iiface False (get_match r)  ¬ has_disc_negated is_Oiface False (get_match r)" by simp (*500ms*)
    with r have abstracted_ifaces: "normalized_ifaces m"
    unfolding normalized_ifaces_def has_disc_negated_disj_split by fastforce

    from transform_lower_closure(3)[OF s1]
      normalized_n_primitive_imp_not_disc_negated[OF wf_disc_sel_common_primitive(1)]
      normalized_n_primitive_imp_not_disc_negated[OF wf_disc_sel_common_primitive(2)]
    have "rset ?rs2. ¬ has_disc_negated is_Src_Ports False (get_match r) 
                       ¬ has_disc_negated is_Dst_Ports False (get_match r) 
                       ¬ has_disc is_MultiportPorts (get_match r)"
      apply(simp add: normalized_src_ports_def2 normalized_dst_ports_def2)
      by blast 
    from this have "rset ?rs3. ¬ has_disc_negated is_Src_Ports False (get_match r) 
                                 ¬ has_disc_negated is_Dst_Ports False (get_match r) 
                                 ¬ has_disc is_MultiportPorts (get_match r)"
      apply -
      apply(rule optimize_matches_preserves)
      apply(intro conjI)
        apply(intro abstract_for_simple_firewall_preserves_nodisc_negated, simp_all)+
      by (simp add: abstract_for_simple_firewall_def abstract_primitive_preserves_nodisc)
    from this protocols_rs3 transform_lower_closure(5)[OF s3, where disc=is_Prot, simplified]
          have "rset ?rs'. ¬ has_disc_negated is_Prot False (get_match r)"
      by simp
    with r have abstracted_prots: "normalized_protocols m"
    unfolding normalized_protocols_def has_disc_negated_disj_split by fastforce
    
    from no_CT no_L4_Flags s4 normalized a abstracted_ifaces abstracted_prots show "normalized_src_ports m 
             normalized_dst_ports m 
             normalized_src_ips m 
             normalized_dst_ips m 
             normalized_ifaces m 
             normalized_protocols m  ¬ has_disc is_L4_Flags m  ¬ has_disc is_CT_State m  
             ¬ has_disc is_MultiportPorts m  ¬ has_disc is_Extra m  (a = action.Accept  a = action.Drop)"
      by(simp)
  }
    hence simple_fw_preconditions: "check_simple_fw_preconditions ?rs'"
    unfolding check_simple_fw_preconditions_def
    by(clarify, rename_tac r, case_tac r, rename_tac m a, simp)

    have 1: "{p. ,p ?rs', Undecided α Decision FinalAllow  newpkt p} =
          {p. ,p ?rs3, Undecided α Decision FinalAllow  newpkt p}"
      apply(subst transform_lower_closure(1)[OF s3])
      by simp
    from abstract_primitive_in_doubt_deny_generic(1)[OF primitive_matcher_generic_common_matcher nnf2 s2] have 2:
         "{p. ,p ?rs3, Undecided α Decision FinalAllow  newpkt p} 
          {p. ,p lower_closure (packet_assume_new rs), Undecided α Decision FinalAllow  newpkt p}"
      by(auto simp add: abstract_for_simple_firewall_def)
    have 3: "{p. ,p lower_closure (packet_assume_new rs), Undecided α Decision FinalAllow  newpkt p} =
          {p. ,p rs, Undecided α Decision FinalAllow  newpkt p}"
      apply(subst transform_lower_closure(1)[OF s1])
      apply(subst approximating_semantics_iff_fun_good_ruleset[OF simple_imp_good_ruleset[OF s1]])
      apply(subst approximating_semantics_iff_fun_good_ruleset[OF simple_imp_good_ruleset[OF simplers]])
      using packet_assume_new newpkt_def by fastforce
      
    have 4: "p. ,p ?rs', Undecided α Decision FinalAllow  ?fw ?rs' p = Decision FinalAllow"
      using approximating_semantics_iff_fun_good_ruleset[OF simple_imp_good_ruleset[OF s4]] by fast
    
    have "{p. ,p ?rs', Undecided α Decision FinalAllow  newpkt p} 
          {p. ,p rs, Undecided α Decision FinalAllow  newpkt p}"
      apply(subst 1)
      apply(subst 3[symmetric])
      using 2 by blast
    
    thus "{p. simple_fw (to_simple_firewall ?rs') p = Decision FinalAllow  newpkt p} 
          {p. ,p rs, Undecided α Decision FinalAllow  newpkt p} "
      apply safe
      subgoal for p using to_simple_firewall[OF simple_fw_preconditions, where p = p] 4 by auto
    done
  qed


definition "to_simple_firewall_without_interfaces ipassmt rtblo rs 
    to_simple_firewall
    (upper_closure
    (optimize_matches (abstract_primitive (λr. case r of Pos a  is_Iiface a  is_Oiface a | Neg a  is_Iiface a  is_Oiface a))
    (optimize_matches abstract_for_simple_firewall
    (upper_closure
    (iface_try_rewrite ipassmt rtblo
    (upper_closure
    (packet_assume_new rs)))))))"



(*basically a copy&paste from transform_simple_fw_upper. but this one is way cleaner! refactor the other using this!*)
theorem to_simple_firewall_without_interfaces:
  defines "newpkt p  match_tcp_flags ipt_tcp_syn (p_tcp_flags p)  p_tag_ctstate p = CT_New"
  assumes simplers: "simple_ruleset (rs:: 'i::len common_primitive rule list)"

      ― ‹well-formed ipassmt›
      and wf_ipassmt1: "ipassmt_sanity_nowildcards (map_of ipassmt)" and wf_ipassmt2: "distinct (map fst ipassmt)"
      ― ‹There are no spoofed packets (probably by kernel's reverse path filter or our checker).
         This assumption implies that ipassmt lists ALL interfaces (!!).›
      and nospoofing: "(p::('i::len, 'a) tagged_packet_scheme).
            ips. (map_of ipassmt) (Iface (p_iiface p)) = Some ips  p_src p  ipcidr_union_set (set ips)"
      ― ‹If a routing table was passed, the output interface for any packet we consider is decided based on it.›
      and routing_decided: "rtbl (p::('i,'a) tagged_packet_scheme). rtblo = Some rtbl  output_iface (routing_table_semantics rtbl (p_dst p)) = p_oiface p"
      ― ‹A passed routing table is wellformed›
      and correct_routing: "rtbl. rtblo = Some rtbl  correct_routing rtbl"
      ― ‹A passed routing table contains no interfaces with wildcard names›
      and routing_no_wildcards: "rtbl. rtblo = Some rtbl  ipassmt_sanity_nowildcards (map_of (routing_ipassmt rtbl))"

  ― ‹the set of new packets, which are accepted is an overapproximations›
  shows "{p::('i,'a) tagged_packet_scheme. (common_matcher, in_doubt_allow),p rs, Undecided α Decision FinalAllow  newpkt p} 
         {p::('i,'a) tagged_packet_scheme. simple_fw (to_simple_firewall_without_interfaces ipassmt rtblo rs) p = Decision FinalAllow  newpkt p}"

  and "r  set (to_simple_firewall_without_interfaces ipassmt rtblo rs).
          iiface (match_sel r) = ifaceAny  oiface (match_sel r) = ifaceAny"
  proof -
    let ?rs1="packet_assume_new rs"
    let ?rs2="upper_closure ?rs1"
    let ?rs3="iface_try_rewrite ipassmt rtblo ?rs2"
    let ?rs4="upper_closure ?rs3"
    let ?rs5="optimize_matches abstract_for_simple_firewall ?rs4"
    let ?rs6="optimize_matches (abstract_primitive (λr. case r of Pos a  is_Iiface a  is_Oiface a | Neg a  is_Iiface a  is_Oiface a)) ?rs5"
    let ?rs7="upper_closure ?rs6"
    let ="(common_matcher, in_doubt_allow)
          :: ('i::len common_primitive, ('i, 'a) tagged_packet_scheme) match_tac"

    have "to_simple_firewall_without_interfaces ipassmt rtblo rs = to_simple_firewall ?rs7"
      by(simp add: to_simple_firewall_without_interfaces_def)

    from packet_assume_new_simple_ruleset[OF simplers] have s1: "simple_ruleset ?rs1" .
    from transform_upper_closure(2)[OF s1] have s2: "simple_ruleset ?rs2" .
    from iface_try_rewrite_simplers[OF s2] have s3: "simple_ruleset ?rs3" .
    from transform_upper_closure(2)[OF s3] have s4: "simple_ruleset ?rs4" .
    from optimize_matches_simple_ruleset[OF s4] have s5: "simple_ruleset ?rs5" .
    from optimize_matches_simple_ruleset[OF s5] have s6: "simple_ruleset ?rs6" .
    from transform_upper_closure(2)[OF s6] have s7: "simple_ruleset ?rs7" .

    from transform_upper_closure(3)[OF s1] have nnf2: "rset ?rs2. normalized_nnf_match (get_match r)" by simp
    from transform_upper_closure(3)[OF s3] have nnf4: "rset ?rs4. normalized_nnf_match (get_match r)" by simp
    have nnf5: "rset ?rs5. normalized_nnf_match (get_match r)"
      apply(intro optimize_matches_preserves)
      apply(simp add: abstract_for_simple_firewall_def)
      apply(rule abstract_primitive_preserves_normalized(5))
      using nnf4 by(simp)
    have nnf6: "rset ?rs6. normalized_nnf_match (get_match r)"
      apply(intro optimize_matches_preserves)
      apply(rule abstract_primitive_preserves_normalized(5))
      using nnf5 by(simp)
    from transform_upper_closure(3)[OF s6] have nnf7: "rset ?rs7. normalized_nnf_match (get_match r)" by simp


    (*subgoal @{term "check_simple_fw_preconditions ?rs7"}*)
    { fix m a
      assume r: "Rule m a  set ?rs7"
  
      from s7 r have a: "(a = action.Accept  a = action.Drop)" by(auto simp add: simple_ruleset_def)
      
      from abstract_for_simple_firewall_hasdisc have "rset ?rs5. ¬ has_disc is_CT_State (get_match r)"
        by(intro optimize_matches_preserves, blast)
      with abstract_primitive_preserves_nodisc[where disc'="is_CT_State"] have
        "rset ?rs6. ¬ has_disc is_CT_State (get_match r)"
        apply(intro optimize_matches_preserves)
        apply(simp)
        by blast
      with transform_upper_closure(4)[OF s6, where disc=is_CT_State] have
        "rset ?rs7. ¬ has_disc is_CT_State (get_match r)" by simp
      with r have no_CT: "¬ has_disc is_CT_State m" by fastforce

      from abstract_for_simple_firewall_hasdisc have "rset ?rs5. ¬ has_disc is_L4_Flags (get_match r)"
        by(intro optimize_matches_preserves, blast)
      with abstract_primitive_preserves_nodisc[where disc'="is_L4_Flags"] have
        "rset ?rs6. ¬ has_disc is_L4_Flags (get_match r)"
        by(intro optimize_matches_preserves) auto
      with transform_upper_closure(4)[OF s6, where disc=is_L4_Flags] have
        "rset ?rs7. ¬ has_disc is_L4_Flags (get_match r)" by simp
      with r have no_L4_Flags: "¬ has_disc is_L4_Flags m" by fastforce


      have "rset ?rs6. ¬ has_disc is_Iiface (get_match r)"
        by(intro optimize_matches_preserves abstract_primitive_nodisc) simp+
      with transform_upper_closure(4)[OF s6, where disc=is_Iiface] have
        "rset ?rs7. ¬ has_disc is_Iiface (get_match r)" by simp
      with r have no_Iiface: "¬ has_disc is_Iiface m" by fastforce

      have "rset ?rs6. ¬ has_disc is_Oiface (get_match r)"
        by(intro optimize_matches_preserves abstract_primitive_nodisc) simp+
      with transform_upper_closure(4)[OF s6, where disc=is_Oiface] have
        "rset ?rs7. ¬ has_disc is_Oiface (get_match r)" by simp
      with r have no_Oiface: "¬ has_disc is_Oiface m" by fastforce

      from no_Iiface no_Oiface have normalized_ifaces: "normalized_ifaces m"
        using has_disc_negated_disj_split has_disc_negated_has_disc normalized_ifaces_def by blast

      from transform_upper_closure(3)[OF s6] r have normalized:
        "normalized_src_ports m  normalized_dst_ports m 
         normalized_src_ips m  normalized_dst_ips m 
         ¬ has_disc is_MultiportPorts m  ¬ has_disc is_Extra m" by fastforce


      from transform_upper_closure(3)[OF s3, simplified]
        normalized_n_primitive_imp_not_disc_negated[OF wf_disc_sel_common_primitive(1)]
        normalized_n_primitive_imp_not_disc_negated[OF wf_disc_sel_common_primitive(2)]
      have "r  set ?rs4. ¬ has_disc_negated is_Src_Ports False (get_match r) 
                           ¬ has_disc_negated is_Dst_Ports False (get_match r) 
                           ¬ has_disc is_MultiportPorts (get_match r)"
        apply(simp add: normalized_src_ports_def2 normalized_dst_ports_def2)
        by blast
      hence "r  set ?rs5. ¬ has_disc_negated is_Src_Ports False (get_match r) 
                            ¬ has_disc_negated is_Dst_Ports False (get_match r) 
                            ¬ has_disc is_MultiportPorts (get_match r)"
        apply -
        apply(rule optimize_matches_preserves)
        apply(intro conjI)
          apply(intro abstract_for_simple_firewall_preserves_nodisc_negated, simp_all)+
        by (simp add: abstract_for_simple_firewall_def abstract_primitive_preserves_nodisc)
      from this have no_ports_rs6: 
            "r  set ?rs6. ¬ has_disc_negated is_Src_Ports False (get_match r) 
                            ¬ has_disc_negated is_Dst_Ports False (get_match r) 
                            ¬ has_disc is_MultiportPorts (get_match r)"
        apply -
        apply(rule optimize_matches_preserves)
        apply(intro conjI)
          apply(intro abstract_primitive_preserves_nodisc_nedgated, simp_all)+
        by (simp add: abstract_for_simple_firewall_def abstract_primitive_preserves_nodisc)

      from nnf4 abstract_for_simple_firewall_negated_ifaces_prots(2) have 
        "rset ?rs5. ¬ has_disc_negated is_Prot False (get_match r)"
        by(intro optimize_matches_preserves) blast
      hence "rset ?rs6. ¬ has_disc_negated is_Prot False (get_match r)"
        by(intro optimize_matches_preserves abstract_primitive_preserves_nodisc_nedgated) simp+
      with no_ports_rs6 have "rset ?rs7. ¬ has_disc_negated is_Prot False (get_match r)"
       by(intro transform_upper_closure(5)[OF s6]) simp+
      with r have protocols: "normalized_protocols m" unfolding normalized_protocols_def by fastforce


      from no_CT no_L4_Flags normalized a normalized_ifaces protocols no_Iiface no_Oiface 
         have "normalized_src_ports m 
               normalized_dst_ports m 
               normalized_src_ips m 
               normalized_dst_ips m 
               normalized_ifaces m 
               normalized_protocols m 
               ¬ has_disc is_L4_Flags m 
               ¬ has_disc is_CT_State m 
               ¬ has_disc is_MultiportPorts m 
               ¬ has_disc is_Extra m  (a = action.Accept  a = action.Drop)"
        and "¬ has_disc is_Iiface m" and "¬ has_disc is_Oiface m"
        apply -
        by(simp)+ (*fails due to is_MultiportPorts*)
    }
    hence simple_fw_preconditions: "check_simple_fw_preconditions ?rs7"
      and no_interfaces: "Rule m a  set ?rs7  ¬ has_disc is_Iiface m  ¬ has_disc is_Oiface m" for m a
    apply -
     subgoal unfolding check_simple_fw_preconditions_def by(clarify, rename_tac r, case_tac r, rename_tac m a, simp)
    by simp


    have "{p :: ('i,'a) tagged_packet_scheme. ,p rs, Undecided α Decision FinalAllow  newpkt p} =
          {p :: ('i,'a) tagged_packet_scheme. ,p ?rs1, Undecided α Decision FinalAllow  newpkt p}"
      apply(subst approximating_semantics_iff_fun_good_ruleset[OF simple_imp_good_ruleset[OF s1]])
      apply(subst approximating_semantics_iff_fun_good_ruleset[OF simple_imp_good_ruleset[OF simplers]])
      apply(rule Collect_cong)
      subgoal for p using packet_assume_new[where p = p] newpkt_def[where p = p] by auto
      done
    also have "{p. ,p ?rs1, Undecided α Decision FinalAllow  newpkt p} =
          {p. ,p ?rs2, Undecided α Decision FinalAllow  newpkt p}"
      apply(subst transform_upper_closure(1)[OF s1])
      by simp
    also have " = {p. ,p ?rs3, Undecided α Decision FinalAllow  newpkt p}"
      apply(cases rtblo; simp; (subst iface_try_rewrite_rtbl[OF s2 nnf2] | subst iface_try_rewrite_no_rtbl[OF s2 nnf2]))
        using wf_ipassmt1 wf_ipassmt2 nospoofing wf_in_doubt_allow routing_no_wildcards correct_routing routing_decided by simp_all
    also have " = {p. ,p ?rs4, Undecided α Decision FinalAllow  newpkt p}"
      apply(subst transform_upper_closure(1)[OF s3])
      by simp
    finally have 1: "{p. ,p rs, Undecided α Decision FinalAllow  newpkt p} =
                  {p. ,p ?rs4, Undecided α Decision FinalAllow  newpkt p}" .
    from abstract_primitive_in_doubt_allow_generic(2)[OF primitive_matcher_generic_common_matcher nnf4 s4] have 2:
         "{p. ,p ?rs4, Undecided α Decision FinalAllow  newpkt p} 
          {p. ,p ?rs5, Undecided α Decision FinalAllow  newpkt p}"
      by(auto simp add: abstract_for_simple_firewall_def)
    from abstract_primitive_in_doubt_allow_generic(2)[OF primitive_matcher_generic_common_matcher nnf5 s5] have 3:
         "{p. ,p ?rs5, Undecided α Decision FinalAllow  newpkt p} 
          {p. ,p ?rs6, Undecided α Decision FinalAllow  newpkt p}"
      by(auto simp add: abstract_for_simple_firewall_def)
    have 4: "{p. ,p ?rs6, Undecided α Decision FinalAllow  newpkt p} =
             {p. ,p ?rs7, Undecided α Decision FinalAllow  newpkt p}"
      apply(subst transform_upper_closure(1)[OF s6])
      by simp

      
    let ?fw="λrs p. approximating_bigstep_fun  p rs Undecided"
    have approximating_rule: "p. ,p ?rs7, Undecided α Decision FinalAllow  ?fw ?rs7 p = Decision FinalAllow"
      using approximating_semantics_iff_fun_good_ruleset[OF simple_imp_good_ruleset[OF s7]] by fast
    
    from 1 2 3 4 have "{p. ,p rs, Undecided α Decision FinalAllow  newpkt p} 
       {p. ,p ?rs7, Undecided α Decision FinalAllow  newpkt p}" by blast
    
    thus "{p. (common_matcher, in_doubt_allow),p rs, Undecided α Decision FinalAllow  newpkt p} 
         {p. simple_fw (to_simple_firewall_without_interfaces ipassmt rtblo rs) p = Decision FinalAllow  newpkt p}"
      apply(safe)
      subgoal for p   
       unfolding to_simple_firewall_without_interfaces_def
       using to_simple_firewall[OF simple_fw_preconditions, where p = p] approximating_rule[where p = p] by auto
      done

    (*the following proof to show that we don't have interfaces left is MADNESS*)

    have common_primitive_match_to_simple_match_nodisc: 
      "Some sm = common_primitive_match_to_simple_match m' 
       ¬ has_disc is_Iiface m'  ¬ has_disc is_Oiface m'  iiface sm = ifaceAny  oiface sm = ifaceAny"
    if prems: "check_simple_fw_preconditions [Rule m' a']"
    for m' :: "'i common_primitive match_expr" and a' sm
    using prems proof(induction m' arbitrary: sm rule: common_primitive_match_to_simple_match.induct)
    case 18 thus ?case
    by(simp add: check_simple_fw_preconditions_def normalized_protocols_def)
    next
    case (13 m1 m2) thus ?case
      (*This is madness!!*)
      apply(simp add: check_simple_fw_preconditions_def)
      apply(case_tac "common_primitive_match_to_simple_match m1")
       apply(simp; fail)
      apply(case_tac "common_primitive_match_to_simple_match m2")
       apply(simp; fail)
      apply simp
      apply(rename_tac a aa)
      apply(case_tac a)
      apply(case_tac aa)
      apply(simp)
      apply(simp split: option.split_asm)
      using iface_conjunct_ifaceAny normalized_ifaces_def normalized_protocols_def
      by (metis has_disc_negated.simps(4) option.inject)
    qed(simp_all add: check_simple_fw_preconditions_def simple_match_any_def)

    have to_simple_firewall_no_ifaces: "(m a. Rule m a  set rs  ¬ has_disc is_Iiface m  ¬ has_disc is_Oiface m)  
        rset (to_simple_firewall rs). iiface (match_sel r) = ifaceAny  oiface (match_sel r) = ifaceAny"
      if pre1: "check_simple_fw_preconditions rs" for rs :: "'i common_primitive rule list"
    using pre1 apply(induction rs)
     apply(simp add: to_simple_firewall_simps; fail)
    apply simp
    apply(subgoal_tac "check_simple_fw_preconditions rs")
     prefer 2
     subgoal by(simp add: check_simple_fw_preconditions_def)
    apply(rename_tac r rs, case_tac r)
    apply simp
    apply(simp add: to_simple_firewall_simps)
    apply(simp split: option.split)
    apply(intro conjI)
     apply blast
    apply(intro allI impI)
    apply(subgoal_tac "(mset (to_simple_firewall rs). iiface (match_sel m) = ifaceAny  oiface (match_sel m) = ifaceAny)")
     prefer 2
     subgoal by blast
    apply(simp)
    apply(rename_tac m' a' sm)
    apply(subgoal_tac " ¬ has_disc is_Iiface m'  ¬ has_disc is_Oiface m'")
     prefer 2
     subgoal by blast
    apply(subgoal_tac "check_simple_fw_preconditions [Rule m' a']")
     prefer 2
     subgoal by(simp add: check_simple_fw_preconditions_def)
    apply(drule common_primitive_match_to_simple_match_nodisc)
      apply(simp_all)
    done
   
    from to_simple_firewall_no_ifaces[OF simple_fw_preconditions no_interfaces] show 
      "r  set (to_simple_firewall_without_interfaces ipassmt rtblo rs). iiface (match_sel r) = ifaceAny  oiface (match_sel r) = ifaceAny"
      unfolding to_simple_firewall_without_interfaces_def
      by(simp add: to_simple_firewall_def simple_fw_preconditions)
      
  qed



end

Theory Semantics_Embeddings

theory Semantics_Embeddings
imports "Simple_Firewall/SimpleFw_Compliance" Matching_Embeddings Semantics "Semantics_Ternary/Semantics_Ternary"
begin


section‹Semantics Embedding›

subsection‹Tactic @{const in_doubt_allow}

lemma iptables_bigstep_undecided_to_undecided_in_doubt_allow_approx:
  assumes agree: "matcher_agree_on_exact_matches γ β"
      and good: "good_ruleset rs" and semantics: "Γ,γ,p rs, Undecided  Undecided"
    shows "(β, in_doubt_allow),p rs, Undecided α Undecided  (β, in_doubt_allow),p rs, Undecided α Decision FinalAllow"
  proof -
    from semantics good show ?thesis
    proof(induction rs Undecided Undecided rule: iptables_bigstep_induct)
      case Skip thus ?case by(auto intro: approximating_bigstep.skip)
      next
      case Log thus ?case by(auto intro: approximating_bigstep.empty approximating_bigstep.log approximating_bigstep.nomatch)
      next
      case (Nomatch m a)
        with not_exact_match_in_doubt_allow_approx_match[OF agree] have
        "a  Log  a  Empty  a = Accept  Matching_Ternary.matches (β, in_doubt_allow) m a p  ¬ Matching_Ternary.matches (β, in_doubt_allow) m a p"
          by(simp add: good_ruleset_alt) blast
      thus ?case
        by(cases a) (auto intro: approximating_bigstep.empty approximating_bigstep.log approximating_bigstep.accept approximating_bigstep.nomatch)
      next
      case (Seq rs rs1 rs2 t)
        from Seq have "good_ruleset rs1" and "good_ruleset rs2" by(simp_all add: good_ruleset_append)
        also from Seq iptables_bigstep_to_undecided have "t = Undecided" by simp
        ultimately show ?case using Seq by(fastforce intro: approximating_bigstep.decision Semantics_Ternary.seq')
    qed(simp_all add: good_ruleset_def)
  qed


lemma FinalAllow_approximating_in_doubt_allow:
   assumes agree: "matcher_agree_on_exact_matches γ β"
       and good: "good_ruleset rs" and semantics: "Γ,γ,p rs, Undecided  Decision FinalAllow"
     shows "(β, in_doubt_allow),p rs, Undecided α Decision FinalAllow"
  proof -
    from semantics good show ?thesis
    proof(induction rs Undecided "Decision FinalAllow" rule: iptables_bigstep_induct)
      case Allow thus ?case
       by (auto intro: agree approximating_bigstep.accept in_doubt_allow_allows_Accept)
      next
      case (Seq rs rs1 rs2 t)
        from Seq have good1: "good_ruleset rs1" and good2: "good_ruleset rs2" by(simp_all add: good_ruleset_append)
        show ?case
        proof(cases t)
          case Decision with Seq good1 good2 show "(β, in_doubt_allow),p rs, Undecided α Decision FinalAllow"
            by (auto intro: approximating_bigstep.decision approximating_bigstep.seq dest: Semantics.decisionD)
          next
          case Undecided
            with iptables_bigstep_undecided_to_undecided_in_doubt_allow_approx[OF agree good1] Seq have
              "(β, in_doubt_allow),p rs1, Undecided α Undecided  (β, in_doubt_allow),p rs1, Undecided α Decision FinalAllow" by simp
            with Undecided Seq good1 good2 show "(β, in_doubt_allow),p rs, Undecided α Decision FinalAllow"
              by (auto intro: approximating_bigstep.seq Semantics_Ternary.seq' approximating_bigstep.decision)
          qed
      next
      case Call_result thus ?case by(simp add: good_ruleset_alt)
    qed
  qed

corollary FinalAllows_subseteq_in_doubt_allow: "matcher_agree_on_exact_matches γ β  good_ruleset rs 
   {p. Γ,γ,p rs, Undecided  Decision FinalAllow}  {p. (β, in_doubt_allow),p rs, Undecided α Decision FinalAllow}"
using FinalAllow_approximating_in_doubt_allow by (metis (lifting, full_types) Collect_mono)


(*referenced by name in paper*)
corollary new_packets_to_simple_firewall_overapproximation:
  defines "preprocess rs  upper_closure (optimize_matches abstract_for_simple_firewall (upper_closure (packet_assume_new rs)))"
  and "newpkt p  match_tcp_flags ipt_tcp_syn (p_tcp_flags p)  p_tag_ctstate p = CT_New"
  fixes p :: "('i::len, 'pkt_ext) tagged_packet_scheme"
  assumes "matcher_agree_on_exact_matches γ common_matcher" and "simple_ruleset rs"
  shows "{p. Γ,γ,p rs, Undecided  Decision FinalAllow  newpkt p}  {p. simple_fw (to_simple_firewall (preprocess rs)) p = Decision FinalAllow  newpkt p}"
proof -
  from assms(3) have "{p. Γ,γ,p rs, Undecided  Decision FinalAllow  newpkt p} 
      {p. (common_matcher, in_doubt_allow),p rs, Undecided α Decision FinalAllow  newpkt p}"
    apply(drule_tac rs=rs and Γ=Γ in FinalAllows_subseteq_in_doubt_allow)
     using simple_imp_good_ruleset assms(4) apply blast
    by blast
  thus ?thesis unfolding newpkt_def preprocess_def using transform_simple_fw_upper(2)[OF assms(4)] by blast
qed



lemma approximating_bigstep_undecided_to_undecided_in_doubt_allow_approx: "matcher_agree_on_exact_matches γ β 
       good_ruleset rs 
       (β, in_doubt_allow),p rs, Undecided α Undecided  Γ,γ,p rs, Undecided  Undecided   Γ,γ,p rs, Undecided  Decision FinalDeny"
 apply(rotate_tac 2)
 apply(induction rs Undecided Undecided rule: approximating_bigstep_induct)
    apply(simp_all)
    apply (metis iptables_bigstep.skip)
   apply (metis iptables_bigstep.empty iptables_bigstep.log iptables_bigstep.nomatch)
  apply(simp split: ternaryvalue.split_asm add: matches_case_ternaryvalue_tuple)
   apply (metis in_doubt_allow_allows_Accept iptables_bigstep.nomatch matches_casesE ternaryvalue.distinct(1) ternaryvalue.distinct(5))
  apply(case_tac a)
          apply(simp_all)
         apply (metis iptables_bigstep.drop iptables_bigstep.nomatch)
        apply (metis iptables_bigstep.log iptables_bigstep.nomatch)
       apply (metis iptables_bigstep.nomatch iptables_bigstep.reject)
      apply(simp add: good_ruleset_alt)
     apply(simp add: good_ruleset_alt)
    apply(simp add: good_ruleset_alt)
   apply (metis iptables_bigstep.empty iptables_bigstep.nomatch)
  apply(simp add: good_ruleset_alt)
 apply(simp add: good_ruleset_append,clarify)
 by (metis approximating_bigstep_to_undecided iptables_bigstep.decision iptables_bigstep.seq)

lemma FinalDeny_approximating_in_doubt_allow: "matcher_agree_on_exact_matches γ β 
   good_ruleset rs 
   (β, in_doubt_allow),p rs, Undecided α Decision FinalDeny  Γ,γ,p rs, Undecided  Decision FinalDeny"
 apply(rotate_tac 2)
 apply(induction rs Undecided "Decision FinalDeny" rule: approximating_bigstep_induct)
  apply(simp_all)
 apply (metis action.distinct(1) action.distinct(5) deny not_exact_match_in_doubt_allow_approx_match) 
 apply(simp add: good_ruleset_append, clarify)
 apply(case_tac t)
   apply(simp)
   apply(drule(2) approximating_bigstep_undecided_to_undecided_in_doubt_allow_approx[where Γ=Γ])
   apply(erule disjE)
    apply (metis iptables_bigstep.seq)
   apply (metis iptables_bigstep.decision iptables_bigstep.seq)
 by (metis Decision_approximating_bigstep_fun approximating_semantics_imp_fun iptables_bigstep.decision iptables_bigstep.seq)


corollary FinalDenys_subseteq_in_doubt_allow: "matcher_agree_on_exact_matches γ β  good_ruleset rs 
   {p. (β, in_doubt_allow),p rs, Undecided α Decision FinalDeny}  {p. Γ,γ,p rs, Undecided  Decision FinalDeny}"
using FinalDeny_approximating_in_doubt_allow by (metis (lifting, full_types) Collect_mono)

text‹
  If our approximating firewall (the executable version) concludes that we deny a packet, 
  the exact semantic agrees that this packet is definitely denied!
›
corollary "matcher_agree_on_exact_matches γ β  good_ruleset rs 
  approximating_bigstep_fun (β, in_doubt_allow) p rs Undecided = (Decision FinalDeny)  Γ,γ,p rs, Undecided  Decision FinalDeny"
apply(frule(1) FinalDeny_approximating_in_doubt_allow[where p=p and Γ=Γ])
 apply(rule approximating_fun_imp_semantics)
  apply (metis good_imp_wf_ruleset)
 apply(simp_all)
done



subsection‹Tactic  @{const in_doubt_deny}


lemma iptables_bigstep_undecided_to_undecided_in_doubt_deny_approx: "matcher_agree_on_exact_matches γ β 
       good_ruleset rs 
       Γ,γ,p rs, Undecided  Undecided 
       (β, in_doubt_deny),p rs, Undecided α Undecided  (β, in_doubt_deny),p rs, Undecided α Decision FinalDeny"
apply(rotate_tac 2)
apply(induction rs Undecided Undecided rule: iptables_bigstep_induct)
     apply(simp_all)
     apply (metis approximating_bigstep.skip)
    apply (metis approximating_bigstep.empty approximating_bigstep.log approximating_bigstep.nomatch)
   apply(case_tac "a = Log")
    apply (metis approximating_bigstep.log approximating_bigstep.nomatch)
   apply(case_tac "a = Empty")
    apply (metis approximating_bigstep.empty approximating_bigstep.nomatch)
   apply(drule_tac a=a in not_exact_match_in_doubt_deny_approx_match)
     apply(simp_all)
    apply(simp add: good_ruleset_alt)
    apply fast
   apply (metis approximating_bigstep.drop approximating_bigstep.nomatch approximating_bigstep.reject)
  apply(frule iptables_bigstep_to_undecided)
  apply(simp)
  apply(simp add: good_ruleset_append)
  apply (metis (hide_lams, no_types) approximating_bigstep.decision Semantics_Ternary.seq')
 apply(simp add: good_ruleset_def)
apply(simp add: good_ruleset_def)
done


lemma FinalDeny_approximating_in_doubt_deny: "matcher_agree_on_exact_matches γ β 
   good_ruleset rs 
   Γ,γ,p rs, Undecided  Decision FinalDeny  (β, in_doubt_deny),p rs, Undecided α Decision FinalDeny"
 apply(rotate_tac 2)
 apply(induction rs Undecided "Decision FinalDeny" rule: iptables_bigstep_induct)
   apply(simp_all)
   apply (metis approximating_bigstep.drop approximating_bigstep.reject in_doubt_deny_denies_DropReject)
   apply(case_tac t)
    apply(simp_all)
    prefer 2
    apply(simp add: good_ruleset_append)
    apply (metis approximating_bigstep.decision approximating_bigstep.seq Semantics.decisionD state.inject)
   apply(simp add: good_ruleset_append, clarify)
   apply(drule(2) iptables_bigstep_undecided_to_undecided_in_doubt_deny_approx)
   apply(erule disjE)
    apply (metis approximating_bigstep.seq)
   apply (metis approximating_bigstep.decision Semantics_Ternary.seq')
 apply(simp add: good_ruleset_alt)
done




lemma approximating_bigstep_undecided_to_undecided_in_doubt_deny_approx: "matcher_agree_on_exact_matches γ β 
       good_ruleset rs 
       (β, in_doubt_deny),p rs, Undecided α Undecided  Γ,γ,p rs, Undecided  Undecided   Γ,γ,p rs, Undecided  Decision FinalAllow"
 apply(rotate_tac 2)
 apply(induction rs Undecided Undecided rule: approximating_bigstep_induct)
    apply(simp_all)
    apply (metis iptables_bigstep.skip)
   apply (metis iptables_bigstep.empty iptables_bigstep.log iptables_bigstep.nomatch)
  apply(simp split: ternaryvalue.split_asm add: matches_case_ternaryvalue_tuple)
   apply (metis in_doubt_allow_allows_Accept iptables_bigstep.nomatch matches_casesE ternaryvalue.distinct(1) ternaryvalue.distinct(5))
  apply(case_tac a)
         apply(simp_all)
        apply (metis iptables_bigstep.accept iptables_bigstep.nomatch)
       apply (metis iptables_bigstep.log iptables_bigstep.nomatch)
      apply(simp add: good_ruleset_alt)
     apply(simp add: good_ruleset_alt)
    apply(simp add: good_ruleset_alt)
   apply (metis iptables_bigstep.empty iptables_bigstep.nomatch)
  apply(simp add: good_ruleset_alt)
 apply(simp add: good_ruleset_append,clarify)
 by (metis approximating_bigstep_to_undecided iptables_bigstep.decision iptables_bigstep.seq)

lemma FinalAllow_approximating_in_doubt_deny: "matcher_agree_on_exact_matches γ β 
   good_ruleset rs 
   (β, in_doubt_deny),p rs, Undecided α Decision FinalAllow  Γ,γ,p rs, Undecided  Decision FinalAllow"
 apply(rotate_tac 2)
 apply(induction rs Undecided "Decision FinalAllow" rule: approximating_bigstep_induct)
  apply(simp_all)
  apply (metis action.distinct(1) action.distinct(5) iptables_bigstep.accept not_exact_match_in_doubt_deny_approx_match)
 apply(simp add: good_ruleset_append, clarify)
 apply(case_tac t)
  apply(simp)
  apply(drule(2) approximating_bigstep_undecided_to_undecided_in_doubt_deny_approx[where Γ=Γ])
  apply(erule disjE)
   apply (metis iptables_bigstep.seq)
  apply (metis iptables_bigstep.decision iptables_bigstep.seq)
 by (metis Decision_approximating_bigstep_fun approximating_semantics_imp_fun iptables_bigstep.decision iptables_bigstep.seq)


corollary FinalAllows_subseteq_in_doubt_deny: "matcher_agree_on_exact_matches γ β  good_ruleset rs 
   {p. (β, in_doubt_deny),p rs, Undecided α Decision FinalAllow}  {p. Γ,γ,p rs, Undecided  Decision FinalAllow}"
using FinalAllow_approximating_in_doubt_deny by (metis (lifting, full_types) Collect_mono)



corollary new_packets_to_simple_firewall_underapproximation:
  defines "preprocess rs  lower_closure (optimize_matches abstract_for_simple_firewall (lower_closure (packet_assume_new rs)))"
  and "newpkt p  match_tcp_flags ipt_tcp_syn (p_tcp_flags p)  p_tag_ctstate p = CT_New"
  fixes p :: "('i::len, 'pkt_ext) tagged_packet_scheme"
  assumes "matcher_agree_on_exact_matches γ common_matcher" and "simple_ruleset rs"
  shows "{p. simple_fw (to_simple_firewall (preprocess rs)) p = Decision FinalAllow  newpkt p}  {p. Γ,γ,p rs, Undecided  Decision FinalAllow  newpkt p}"
proof -
  from assms(3) have "{p. (common_matcher, in_doubt_deny),p rs, Undecided α Decision FinalAllow  newpkt p} 
      {p. Γ,γ,p rs, Undecided  Decision FinalAllow  newpkt p}"
    apply(drule_tac rs=rs and Γ=Γ in FinalAllows_subseteq_in_doubt_deny)
     using simple_imp_good_ruleset assms(4) apply blast
    by blast
  thus ?thesis unfolding newpkt_def preprocess_def using transform_simple_fw_lower(2)[OF assms(4)] by blast
qed



subsection‹Approximating Closures›

theorem FinalAllowClosure:
  assumes "matcher_agree_on_exact_matches γ β" and "good_ruleset rs"
  shows "{p. (β, in_doubt_deny),p rs, Undecided α Decision FinalAllow}  {p. Γ,γ,p rs, Undecided  Decision FinalAllow}"
  and   "{p. Γ,γ,p rs, Undecided  Decision FinalAllow}  {p. (β, in_doubt_allow),p rs, Undecided α Decision FinalAllow}"  
 apply (metis FinalAllows_subseteq_in_doubt_deny assms)
by (metis FinalAllows_subseteq_in_doubt_allow assms)


theorem FinalDenyClosure:
  assumes "matcher_agree_on_exact_matches γ β" and "good_ruleset rs"
  shows "{p. (β, in_doubt_allow),p rs, Undecided α Decision FinalDeny}  {p. Γ,γ,p rs, Undecided  Decision FinalDeny}"
  and   "{p. Γ,γ,p rs, Undecided  Decision FinalDeny}  {p. (β, in_doubt_deny),p rs, Undecided α Decision FinalDeny}"  
 apply (metis FinalDenys_subseteq_in_doubt_allow assms)
by (metis FinalDeny_approximating_in_doubt_deny assms mem_Collect_eq subsetI)




subsection‹Exact Embedding›

lemma LukassLemma: assumes agree: "matcher_agree_on_exact_matches γ β"
        and noUnknown: "( r  set rs. ternary_ternary_eval (map_match_tac β p (get_match r))  TernaryUnknown)"
        and good: "good_ruleset rs"
      shows "(β,α),p rs, s α t   Γ,γ,p rs, s  t"
proof -
  { fix t ― ‹if we show it for arbitrary @{term t}, we can reuse this fact for the other direction.›
    assume a: "(β,α),p rs, s α t"
    from a good agree noUnknown have "Γ,γ,p rs, s  t"
      proof(induction rs s t rule: approximating_bigstep_induct)
      qed(auto intro: approximating_bigstep.intros iptables_bigstep.intros dest: iptables_bigstepD dest: matches_comply_exact simp: good_ruleset_append)
  } note 1=this
  {
    assume a: "Γ,γ,p rs, s  t"
    obtain x where "approximating_bigstep_fun (β,α) p rs s = x" by simp
    with approximating_fun_imp_semantics[OF good_imp_wf_ruleset[OF good]] have x: "(β,α),p rs, s α x" by fast
    with 1 have "Γ,γ,p rs, s  x" by simp
    with a iptables_bigstep_deterministic have "x = t" by metis
    hence "(β,α),p rs, s α t" using x by blast
  } note 2=this
  from 1 2 show ?thesis by blast
qed
  

text‹
For rulesets without @{term Call}s, the approximating ternary semantics can perfectly simulate the Boolean semantics.
›
theorem βmagic_approximating_bigstep_iff_iptables_bigstep:
  assumes "r  set rs. c. get_action r  Call c"
  shows "((βmagic γ),α),p rs, s α t   Γ,γ,p rs, s  t"
apply(rule iffI)
 apply(induction rs s t rule: approximating_bigstep_induct)
       apply(auto intro: iptables_bigstep.intros simp: βmagic_matching)[7]
apply(insert assms)
apply(induction rs s t rule: iptables_bigstep_induct)
        apply(auto intro: approximating_bigstep.intros simp: βmagic_matching)
done

corollary βmagic_approximating_bigstep_fun_iff_iptables_bigstep:
  assumes "good_ruleset rs"
  shows "approximating_bigstep_fun (βmagic γ,α) p rs s = t   Γ,γ,p rs, s  t"
apply(subst approximating_semantics_iff_fun_good_ruleset[symmetric])
 using assms apply simp
apply(subst βmagic_approximating_bigstep_iff_iptables_bigstep[where Γ=Γ])
 using assms apply (simp add: good_ruleset_def)
by simp



text‹The function @{const optimize_primitive_univ} was only applied to the ternary semantics.
      It is, in fact, also correct for the Boolean semantics, assuming the @{const common_matcher}.›
lemma Semantics_optimize_primitive_univ_common_matcher:
  assumes "matcher_agree_on_exact_matches γ common_matcher" 
    shows "Semantics.matches γ (optimize_primitive_univ m) p = Semantics.matches γ m p"
proof -
  have "65535 = (max_word::16 word)"
    by simp
  then have port_range: "s e port. s = 0  e = 0xFFFF  (port::16 word)  0xFFFF"
    by (simp only:) simp
  from assms show ?thesis
  apply(induction m rule: optimize_primitive_univ.induct)
  apply(auto elim!: matcher_agree_on_exact_matches_gammaE
             simp add: port_range match_ifaceAny ipset_from_cidr_0 ctstate_is_UNIV)
  done
qed

end

Theory Iptables_Semantics

theory Iptables_Semantics
imports Semantics_Embeddings "Semantics_Ternary/Normalized_Matches"
begin

section‹Normalizing Rulesets in the Boolean Big Step Semantics›
corollary normalize_rules_dnf_correct_BooleanSemantics: 
  assumes "good_ruleset rs"
  shows "Γ,γ,p normalize_rules_dnf rs, s  t  Γ,γ,p rs, s  t"
proof -
  from assms have assm': "good_ruleset (normalize_rules_dnf rs)" by (metis good_ruleset_normalize_rules_dnf) 
  from normalize_rules_dnf_correct assms good_imp_wf_ruleset have
    "β α. approximating_bigstep_fun (β,α) p (normalize_rules_dnf rs) s = approximating_bigstep_fun (β,α) p rs s" by fast
  hence 
    "α. approximating_bigstep_fun (βmagic γ,α) p (normalize_rules_dnf rs) s = approximating_bigstep_fun (βmagic γ,α) p rs s" by fast
  with βmagic_approximating_bigstep_fun_iff_iptables_bigstep assms assm' show ?thesis
  by metis
qed

end

Theory Code_Interface

theory Code_Interface
imports 
  Common_Primitive_toString
  IP_Addresses.IP_Address_Parser
  "../Call_Return_Unfolding"
  Transform
  No_Spoof
  "../Simple_Firewall/SimpleFw_Compliance"
  Simple_Firewall.SimpleFw_toString
  Simple_Firewall.Service_Matrix
  "../Semantics_Ternary/Optimizing" (*do we use this?*)
  "../Semantics_Goto"
  Native_Word.Code_Target_Bits_Int
  "HOL-Library.Code_Target_Nat"
  "HOL-Library.Code_Target_Int"
begin

(*Note: common_primitive_match_expr_ipv4_toString can be really slow*)

section‹Code Interface›

text‹HACK: rewrite quotes such that they are better printable by Isabelle›
definition quote_rewrite :: "string  string" where
  "quote_rewrite  map (λc. if c = char_of_nat 34 then CHR ''~'' else c)"

lemma "quote_rewrite (''foo''@[char_of_nat 34]) = ''foo~''" by eval

text‹The parser returns the @{typ "'i::len common_primitive ruleset"} not as a map but as an association list.
      This function converts it›

(*this is only to tighten the types*)
definition map_of_string_ipv4
  :: "(string × 32 common_primitive rule list) list  string  32 common_primitive rule list" where
  "map_of_string_ipv4 rs = map_of rs"
definition map_of_string_ipv6
  :: "(string × 128 common_primitive rule list) list  string  128 common_primitive rule list" where
  "map_of_string_ipv6 rs = map_of rs"
definition map_of_string
  :: "(string × 'i common_primitive rule list) list  string  'i common_primitive rule list" where
  "map_of_string rs = map_of rs"


definition unfold_ruleset_CHAIN_safe :: "string  action  'i::len common_primitive ruleset  'i common_primitive rule list option" where
"unfold_ruleset_CHAIN_safe = unfold_optimize_ruleset_CHAIN optimize_primitive_univ"

lemma "(unfold_ruleset_CHAIN_safe chain a rs = Some rs')  simple_ruleset rs'"
  by(simp add: Let_def unfold_ruleset_CHAIN_safe_def unfold_optimize_ruleset_CHAIN_def split: if_split_asm)

(*This is just for legacy code compatibility. Use the new _safe function instead*)
definition unfold_ruleset_CHAIN :: "string  action  'i::len common_primitive ruleset  'i common_primitive rule list" where
  "unfold_ruleset_CHAIN chain default_action rs = the (unfold_ruleset_CHAIN_safe chain default_action rs)"


definition unfold_ruleset_FORWARD :: "action  'i::len common_primitive ruleset  'i::len common_primitive rule list" where
  "unfold_ruleset_FORWARD = unfold_ruleset_CHAIN ''FORWARD''"

definition unfold_ruleset_INPUT :: "action  'i::len common_primitive ruleset  'i::len common_primitive rule list" where
  "unfold_ruleset_INPUT = unfold_ruleset_CHAIN ''INPUT''"

definition unfold_ruleset_OUTPUT :: "action  'i::len common_primitive ruleset  'i::len common_primitive rule list" where
  "unfold_ruleset_OUTPUT  unfold_ruleset_CHAIN ''OUTPUT''"


lemma "let fw = [''FORWARD''  []] in
  unfold_ruleset_FORWARD action.Drop fw
  = [Rule (MatchAny :: 32 common_primitive match_expr) action.Drop]" by eval


(* only used for ML/Haskell code to convert types *)
definition nat_to_8word :: "nat  8 word" where
  "nat_to_8word i  of_nat i"

definition nat_to_16word :: "nat  16 word" where
  "nat_to_16word i  of_nat i"

definition integer_to_16word :: "integer  16 word" where
  "integer_to_16word i  nat_to_16word (nat_of_integer i)"




context
begin
  private definition is_pos_Extra :: "'i::len common_primitive negation_type  bool" where
    "is_pos_Extra a  (case a of Pos (Extra _)  True | _  False)"
  private definition get_pos_Extra :: "'i::len common_primitive negation_type  string" where
    "get_pos_Extra a  (case a of Pos (Extra e)  e | _  undefined)"
  
  fun compress_parsed_extra
    :: "'i::len common_primitive negation_type list  'i common_primitive negation_type list" where
    "compress_parsed_extra [] = []" |
    "compress_parsed_extra (a1#a2#as) = (if is_pos_Extra a1  is_pos_Extra a2
        then compress_parsed_extra (Pos (Extra (get_pos_Extra a1@'' ''@get_pos_Extra a2))#as)
        else a1#compress_parsed_extra (a2#as)
        )" |
    "compress_parsed_extra (a#as) = a#compress_parsed_extra as"
  
  lemma "compress_parsed_extra
    (map Pos [Extra ''-m'', (Extra ''recent'' :: 32 common_primitive),
              Extra ''--update'', Extra ''--seconds'', Extra ''60'',
              IIface (Iface ''foobar''),
              Extra ''--name'', Extra ''DEFAULT'', Extra ''--rsource'']) =
     map Pos [Extra ''-m recent --update --seconds 60'',
              IIface (Iface ''foobar''),
              Extra ''--name DEFAULT --rsource'']" by eval
  
  private lemma eval_ternary_And_Unknown_Unkown:
    "eval_ternary_And TernaryUnknown (eval_ternary_And TernaryUnknown tv) =
        eval_ternary_And TernaryUnknown tv"
    by(cases tv) (simp_all)
  
  private lemma is_pos_Extra_alist_and:
    "is_pos_Extra a  alist_and (a#as) = MatchAnd (Match (Extra (get_pos_Extra a))) (alist_and as)"
    apply(cases a)
     apply(simp_all add: get_pos_Extra_def is_pos_Extra_def)
    apply(rename_tac e)
    by(case_tac e)(simp_all)
  
  private lemma compress_parsed_extra_matchexpr_helper:
    "ternary_ternary_eval (map_match_tac common_matcher p (alist_and (compress_parsed_extra as))) =
         ternary_ternary_eval (map_match_tac common_matcher p (alist_and as))"
   proof(induction as rule: compress_parsed_extra.induct)
   case 1 thus ?case by(simp)
   next
   case (2 a1 a2) thus ?case
     apply(simp add: is_pos_Extra_alist_and)
     apply(cases a1)
      apply(simp_all add: eval_ternary_And_Unknown_Unkown)
     done
   next
   case 3 thus ?case by(simp)
   qed
  
  text‹This lemma justifies that it is okay to fold together the parsed unknown tokens›
  lemma compress_parsed_extra_matchexpr:
    "matches (common_matcher, α) (alist_and (compress_parsed_extra as)) =
        matches (common_matcher, α) (alist_and as)"
    apply(simp add: fun_eq_iff)
    apply(intro allI)
    apply(rule matches_iff_apply_f)
    apply(simp add: compress_parsed_extra_matchexpr_helper)
    done
end




subsection‹L4 Ports Parser Helper›

context
begin
  text‹Replace all matches on ports with the unspecified @{term 0} protocol with the given @{typ primitive_protocol}.›
  private definition fill_l4_protocol_raw
    :: "primitive_protocol  'i::len common_primitive negation_type list  'i common_primitive negation_type list"
  where
    "fill_l4_protocol_raw protocol  NegPos_map
      (λ m. case m of Src_Ports (L4Ports x pts)  if x  0 then undefined else Src_Ports (L4Ports protocol pts)
                   |  Dst_Ports (L4Ports x pts)  if x  0 then undefined else Dst_Ports (L4Ports protocol pts)
                   |  MultiportPorts (L4Ports x pts)  if x  0 then undefined else MultiportPorts (L4Ports protocol pts)
                   |  Prot _  undefined ― ‹there should be no more match on the protocol if it was parsed from an iptables-save line›
                   | m  m
      )"

  lemma "fill_l4_protocol_raw TCP [Neg (Dst (IpAddrNetmask (ipv4addr_of_dotdecimal (127, 0, 0, 0)) 8)), Pos (Src_Ports (L4Ports 0 [(22,22)]))] =
          [Neg (Dst (IpAddrNetmask 0x7F000000 8)), Pos (Src_Ports (L4Ports 6 [(0x16, 0x16)]))]" by eval

  fun fill_l4_protocol
    :: "'i::len common_primitive negation_type list  'i::len common_primitive negation_type list"
  where
    "fill_l4_protocol [] = []" |
    "fill_l4_protocol (Pos (Prot (Proto protocol)) # ms) = Pos (Prot (Proto protocol)) # fill_l4_protocol_raw protocol ms" |
    "fill_l4_protocol (Pos (Src_Ports _) # _) = undefined" | (*need to find proto first*)
    "fill_l4_protocol (Pos (Dst_Ports _) # _) = undefined" |
    "fill_l4_protocol (Pos (MultiportPorts _) # _) = undefined" |
    "fill_l4_protocol (Neg (Src_Ports _) # _) = undefined" |
    "fill_l4_protocol (Neg (Dst_Ports _) # _) = undefined" |
    "fill_l4_protocol (Neg (MultiportPorts _) # _) = undefined" |
    "fill_l4_protocol (m # ms) = m # fill_l4_protocol ms"

  lemma "fill_l4_protocol [ Neg (Dst (IpAddrNetmask (ipv4addr_of_dotdecimal (127, 0, 0, 0)) 8))
                                , Neg (Prot (Proto UDP))
                                , Pos (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (127, 0, 0, 0)) 8))
                                , Pos (Prot (Proto TCP))
                                , Pos (Extra ''foo'')
                                , Pos (Src_Ports (L4Ports 0 [(22,22)]))
                                , Neg (Extra ''Bar'')] =
  [ Neg (Dst (IpAddrNetmask 0x7F000000 8))
  , Neg (Prot (Proto UDP))
  , Pos (Src (IpAddrNetmask 0x7F000000 8))
  , Pos (Prot (Proto TCP))
  , Pos (Extra ''foo'')
  , Pos (Src_Ports (L4Ports TCP [(0x16, 0x16)]))
  , Neg (Extra ''Bar'')]" by eval
end



(*currently unused and unverifed. may be needed for future use*)
definition prefix_to_strange_inverse_cisco_mask:: "nat  (nat × nat × nat × nat)" where
 "prefix_to_strange_inverse_cisco_mask n  dotdecimal_of_ipv4addr ( (NOT (((mask n)::ipv4addr) << (32 - n))) )"
lemma "prefix_to_strange_inverse_cisco_mask 8 = (0, 255, 255, 255)" by eval
lemma "prefix_to_strange_inverse_cisco_mask 16 = (0, 0, 255, 255)" by eval
lemma "prefix_to_strange_inverse_cisco_mask 24 = (0, 0, 0, 255)" by eval
lemma "prefix_to_strange_inverse_cisco_mask 32 = (0, 0, 0, 0)" by eval


end

Theory Parser6

section‹Parser for iptables-save›
theory Parser6
imports Code_Interface
  keywords "parse_ip6tables_save" :: thy_decl
begin

(*THIS IS A VERBATIM COPY OF THE IPv4 PARSER.
 I JUST HAVE SEARCH/REPLACED s/32/128 and s/ipv4/ipv6
 AND RENAMED THE COMMAND
 ! ! ! do not edit by hand ! ! !*)

ML(*my personal small library*)
fun takeWhile p xs = take_prefix p xs;

fun dropWhile p xs = drop_prefix p xs;

fun dropWhileInclusive p xs = drop 1 (dropWhile p xs)

(*split at the predicate, do NOT keep the position where it was split*)
fun split_at p xs = (takeWhile p xs, dropWhileInclusive p xs);

ML_valsplit_at (fn x => x <> " ") (raw_explode "foo bar")


section‹An SML Parser for iptables-save›
text‹Work in Progress›

MLlocal
  fun is_start_of_table table s = s = ("*"^table);
  fun is_end_of_table s = s = "COMMIT";

  fun load_file (thy: theory) (path: string list) =
      let val p =  File.full_path (Resources.master_directory thy) (Path.make path);
          val _ = "loading file "^File.platform_path p |> writeln;
      in
        if
          not (File.exists p) orelse (File.is_dir p)
        then
          raise Fail "File not found"
        else
          File.read_lines p
      end;

  fun extract_table _ [] = []
   |  extract_table table (r::rs) = if not (is_start_of_table table r)
                                    then
                                      extract_table table rs
                                    else
                                      takeWhile (fn x => not (is_end_of_table x)) rs;

  fun writenumloaded table_name table = let
      val _ = "Loaded "^ Int.toString (length table) ^" lines of the "^table_name^" table" |> writeln;
    in table end;

  fun warn_windows_line_endings lines =
    let
      val warn = fn s => if String.isSuffix "\r" s
                         then
                           writeln "WARNING: windows \\r\\n line ending detected"
                         else
                           ()
      val _ = map warn lines
    in
      lines
    end;
in
  fun load_table table thy = load_file thy
      #> warn_windows_line_endings
      #> extract_table table
      #> writenumloaded table;
  val load_filter_table = load_table "filter";
end;


ML(*keep quoted strings as one token*)
local
  fun collapse_quotes [] = []
   |  collapse_quotes ("\""::ss) = let val (quoted, rest) = split_at (fn x => x <> "\"") ss in
                                          "\"" ^ implode quoted^"\"" :: rest end
   |  collapse_quotes (s::ss) = s :: collapse_quotes ss;
in
  val ipt_explode = raw_explode #> collapse_quotes;
end
ML_valipt_explode "ad \"as das\" boo";
ipt_explode "ad \"foobar --boo boo";
ipt_explode "ent \"\\\"\" this";
ipt_explode "";


(*
ML_val‹
fun finite_scan scan = Scan.error (Scan.finite Symbol.stopper (scan));
finite_scan
     ((Scan.this_string "foo") --|
      (Scan.ahead ($$ " " || Scan.one Symbol.is_eof))) (raw_explode "foo ");
›
ML‹
local
  val errormsg = (fn (ss, _) => raise Fail ("parse error: expected word boundary near `"^implode ss^"'"))
  fun finite_scan scanner = (Scan.finite Symbol.stopper (Scan.error (!! errormsg scanner)));
  val word_boundary_or_end = Scan.ahead ($$ " " || Scan.one Symbol.is_eof)
in
  fun look_ahead_token (scan : (string list -> 'a * string list)) s = (*TODO: why do I need to write the type?*)
          finite_scan (scan --| word_boundary_or_end) s;
end;
val _ = look_ahead_token (Scan.this_string "foo") (raw_explode "foo ");
val _ = look_ahead_token (Scan.this_string "foo") (raw_explode "foo");
val _ = (look_ahead_token (Scan.this_string "foo")) (raw_explode "fo")
  handle Fail m => if m = "parse error: expected word boundary near `fo'" then ("", [])
                   else raise Fail "foo";
›*)

MLdatatype parsed_action_type = TypeCall | TypeGoto
datatype parsed_match_action = ParsedMatch of term
                             | ParsedNegatedMatch of term
                             | ParsedAction of parsed_action_type * string;

local (*iptables-save parsers*)
  val is_whitespace = Scan.many (fn x => x = " ");

  local (*parser for matches*)
    local
      fun extract_int ss = case ss |> implode |> Int.fromString
                                                    of SOME i => i
                                                    |  NONE   => raise Fail "unparsable int";

      fun is_iface_char x = Symbol.is_ascii x andalso
            (Symbol.is_ascii_letter x orelse Symbol.is_ascii_digit x orelse x = "+"
             orelse x = "*" orelse x = "." orelse x = "-")
    in
      fun mk_nat maxval i = if i < 0 orelse i > maxval
                then
                  raise Fail("nat ("^Int.toString i^") must be between 0 and "^Int.toString maxval)
                else (HOLogic.mk_number HOLogic.natT i);

      fun ipNetmask_to_hol (ip,len) = @{const IpAddrNetmask (128)} $ mk_ipv6addr ip $ mk_nat 128 len;
      fun ipRange_to_hol (ip1,ip2) = @{const IpAddrRange (128)} $ mk_ipv6addr ip1 $ mk_ipv6addr ip2;


      val parser_ip_cidr = parser_ipv6 --| ($$ "/") -- (Scan.many1 Symbol.is_ascii_digit >> extract_int) >> ipNetmask_to_hol;

      val parser_ip_range = parser_ipv6 --| ($$ "-") -- parser_ipv6 >> ipRange_to_hol;

      val parser_ip_addr = parser_ipv6 >> (fn ip => @{const IpAddr (128)} $ mk_ipv6addr ip);

      val parser_interface = Scan.many1 is_iface_char >> (implode #> (fn x => @{const Iface} $ HOLogic.mk_string x));

       (*TODO: it would be cool to check for a word boundary after all these strings*)
      val parser_protocol = Scan.this_string "tcp" >> K @{term "TCP :: 8 word"}
                         || Scan.this_string "udp" >> K @{term "UDP :: 8 word"}
                         || (Scan.this_string "icmpv6" (*before icmp*) || Scan.this_string "ipv6-icmp")
                              >> K @{term "L4_Protocol.IPv6ICMP"}
                         || Scan.this_string "icmp" >> K @{term "ICMP :: 8 word"}
                         (*Moar Assigned Internet Protocol Numbers below: *)
                         || Scan.this_string "esp" >> K @{term "L4_Protocol.ESP"}
                         || Scan.this_string "ah" >> K @{term "L4_Protocol.AH"}
                         || Scan.this_string "gre" >> K @{term "L4_Protocol.GRE"}

      val parser_ctstate = Scan.this_string "NEW" >> K @{const CT_New}
                         || Scan.this_string "ESTABLISHED" >> K @{const CT_Established}
                         || Scan.this_string "RELATED" >> K @{const CT_Related}
                         || Scan.this_string "UNTRACKED" >> K @{const CT_Untracked}
                         || Scan.this_string "INVALID" >> K @{const CT_Invalid}

      val parser_tcp_flag = Scan.this_string "SYN" >> K @{const TCP_SYN}
                         || Scan.this_string "ACK" >> K @{const TCP_ACK}
                         || Scan.this_string "FIN" >> K @{const TCP_FIN}
                         || Scan.this_string "RST" >> K @{const TCP_RST}
                         || Scan.this_string "URG" >> K @{const TCP_URG}
                         || Scan.this_string "PSH" >> K @{const TCP_PSH}

      fun parse_comma_separated_list parser = Scan.repeat (parser --| $$ ",") @@@ (parser >> (fn p => [p]))

      local
        val mk_port_single = mk_nat 65535 #> (fn n => @{const nat_to_16word} $ n)
        val parse_port_raw = Scan.many1 Symbol.is_ascii_digit >> extract_int
        fun port_tuple_warn (p1,p2) =
                if p1 >= p2
                then
                  let val _= writeln ("WARNING (in ports): "^Int.toString p1^" >= "^Int.toString p2)
                  in (p1, p2) end
                else (p1, p2);
      in
        val parser_port_single_tup = (
                 (parse_port_raw --| $$ ":" -- parse_port_raw)
                    >> (port_tuple_warn #> (fn (p1,p2) => (mk_port_single p1, mk_port_single p2)))
              || (parse_port_raw  >> (fn p => (mk_port_single p, mk_port_single p)))
            ) >> HOLogic.mk_prod
        end
      val parser_port_single_tup_term = parser_port_single_tup
            >> (fn x => @{term "L4Ports 0"} $ HOLogic.mk_list @{typ "16 word × 16 word"} [x])

      val parser_port_many1_tup = parse_comma_separated_list parser_port_single_tup
            >> (fn x => @{term "L4Ports 0"} $ HOLogic.mk_list @{typ "16 word × 16 word"} x)

      val parser_ctstate_set = parse_comma_separated_list parser_ctstate
            >> HOLogic.mk_set @{typ "ctstate"}

      val parser_tcp_flag_set = parse_comma_separated_list parser_tcp_flag
            >> HOLogic.mk_set @{typ "tcp_flag"}

      val parser_tcp_flags = (parser_tcp_flag_set --| $$ " " -- parser_tcp_flag_set)
            >> (fn (m,c) => @{const TCP_Flags} $ m $ c)

      val parser_extra = Scan.many1 (fn x => x <> " " andalso Symbol.not_eof x)
            >> (implode #> HOLogic.mk_string);
    end;
    val eoo = Scan.ahead ($$ " " || Scan.one Symbol.is_eof); (*end of option; word boundary or eof look-ahead*)

    fun parse_cmd_option_generic (d: term -> parsed_match_action) s t (parser: string list -> (term * string list)) =
        Scan.finite Symbol.stopper (is_whitespace |-- Scan.this_string s |-- (parser >> (fn r => d (t $ r))) --| eoo)

    fun parse_cmd_option (s: string) (t: term) (parser: string list -> (term * string list)) =
            parse_cmd_option_generic ParsedMatch s t parser;

    (*both negated and not negated primitives*)
    fun parse_cmd_option_negated (s: string) (t: term) (parser: string list -> (term * string list)) =
          parse_cmd_option_generic ParsedNegatedMatch ("! "^s) t parser || parse_cmd_option s t parser;

    fun parse_cmd_option_negated_singleton s t parser = parse_cmd_option_negated s t parser >> (fn x => [x])

    (*TODO: is the 'Scan.finite Symbol.stopper' correct here?*)
    (*TODO: eoo here?*)
    fun parse_with_module_prefix (module: string) (parser: (string list -> parsed_match_action * string list)) =
      (Scan.finite Symbol.stopper (is_whitespace |-- Scan.this_string module)) |-- (Scan.repeat parser)
  in

    val parse_ips = parse_cmd_option_negated_singleton "-s " @{const Src (128)} (parser_ip_cidr || parser_ip_addr)
                 || parse_cmd_option_negated_singleton "-d " @{const Dst (128)} (parser_ip_cidr || parser_ip_addr);


    val parse_iprange = parse_with_module_prefix "-m iprange "
                            (   parse_cmd_option_negated "--src-range " @{const Src (128)} parser_ip_range
                             || parse_cmd_option_negated "--dst-range " @{const Dst (128)} parser_ip_range);

    val parse_iface = parse_cmd_option_negated_singleton "-i " @{const IIface (128)} parser_interface
                   || parse_cmd_option_negated_singleton "-o " @{const OIface (128)} parser_interface;

    (*TODO type is explicit here*)
    val parse_protocol = parse_cmd_option_negated_singleton "-p "
                @{term "(Prot  Proto) :: primitive_protocol  128 common_primitive"} parser_protocol; (*negated?*)

    (*-m tcp requires that there is already an -p tcp, iptables checks that for you,
      we assume valid iptables-save (otherwise the kernel would not load it)
      We will fill the protocols in the L4Ports later*)
    val parse_tcp_options = parse_with_module_prefix "-m tcp "
              (   parse_cmd_option_negated "--sport " @{const Src_Ports (128)} parser_port_single_tup_term
               || parse_cmd_option_negated "--dport " @{const Dst_Ports (128)} parser_port_single_tup_term
               || parse_cmd_option_negated "--tcp-flags " @{const L4_Flags (128)} parser_tcp_flags);
    val parse_multiports = parse_with_module_prefix "-m multiport "
              (   parse_cmd_option_negated "--sports " @{const Src_Ports (128)} parser_port_many1_tup
               || parse_cmd_option_negated "--dports " @{const Dst_Ports (128)} parser_port_many1_tup
               || parse_cmd_option_negated "--ports " @{const MultiportPorts (32)} parser_port_many1_tup);
    val parse_udp_options = parse_with_module_prefix "-m udp "
              (   parse_cmd_option_negated "--sport " @{const Src_Ports (128)} parser_port_single_tup_term
               || parse_cmd_option_negated "--dport " @{const Dst_Ports (128)} parser_port_single_tup_term);

    val parse_ctstate = parse_with_module_prefix "-m state "
                  (parse_cmd_option_negated "--state " @{const CT_State (128)} parser_ctstate_set)
              || parse_with_module_prefix "-m conntrack "
                  (parse_cmd_option_negated "--ctstate " @{const CT_State (128)} parser_ctstate_set);

     (*TODO: it would be good to fail if there is a "!" in the extra; it might be an unparsed negation*)
    val parse_unknown = (parse_cmd_option "" @{const Extra (128)} parser_extra) >> (fn x => [x]);
  end;


  local (*parser for target/action*)
    fun is_target_char x = Symbol.is_ascii x andalso
        (Symbol.is_ascii_letter x orelse Symbol.is_ascii_digit x orelse x = "-" orelse x = "_" orelse x = "~")

    fun parse_finite_skipwhite parser = Scan.finite Symbol.stopper (is_whitespace |-- parser);

    val is_icmp_type = fn x => Symbol.is_ascii_letter x orelse x = "-" orelse x = "6"
  in
    val parser_target = Scan.many1 is_target_char >> implode;

    (*parses: -j MY_CUSTOM_CHAIN*)
    (*The -j may not be the end of the line. example: -j LOG --log-prefix "[IPT_DROP]:"*)
    val parse_target_generic : (string list -> parsed_match_action * string list) =  parse_finite_skipwhite
      (Scan.this_string "-j " |-- (parser_target >> (fn s => ParsedAction (TypeCall, s))));

    (*parses: REJECT --reject-with type*)
    val parse_target_reject : (string list -> parsed_match_action * string list) =  parse_finite_skipwhite
      (Scan.this_string "-j " |-- (Scan.this_string "REJECT" >> (fn s => ParsedAction (TypeCall, s)))
       --| ((Scan.this_string " --reject-with " --| Scan.many1 is_icmp_type) || Scan.this_string ""));


    val parse_target_goto : (string list -> parsed_match_action * string list) = parse_finite_skipwhite
      (Scan.this_string "-g " |-- (parser_target >> (fn s => let val _ = writeln ("WARNING: goto in `"^s^"'") in ParsedAction (TypeGoto, s) end)));

    val parse_target : (string list -> parsed_match_action * string list) = parse_target_reject || parse_target_goto || parse_target_generic;
  end;
in
  (*parses: -A FORWARD*)
  val parse_table_append : (string list -> (string * string list)) = Scan.this_string "-A " |-- parser_target --| is_whitespace;

  (*parses: -s 0.31.123.213/88 --foo_bar -j chain --foobar
   First tries to parse a known field, afterwards, it parses something unknown until a blank space appears
  *)
  val option_parser : (string list -> (parsed_match_action list) * string list) =
      Scan.recover (parse_ips || parse_iprange
                 || parse_iface
                 || parse_protocol
                 || parse_tcp_options || parse_udp_options || parse_multiports
                 || parse_ctstate
                 || parse_target >> (fn x => [x])) (K parse_unknown);


  (*parse_table_append should be called before option_parser, otherwise -A will simply be an unknown for option_parser*)

  local
    (*:DOS_PROTECT - [0:0]*)
    val custom_chain_decl_parser = ($$ ":") |-- parser_target --| Scan.this_string " - " #> fst;
    (*:INPUT ACCEPT [130:12050]*)
    (*TODO: PREROUTING is only valid if we are in the raw table*)
    val builtin_chain_decl_parser = ($$ ":") |--
      (Scan.this_string "INPUT" || Scan.this_string "FORWARD" || Scan.this_string "OUTPUT" || Scan.this_string "PREROUTING") --|
      ($$ " ") -- (Scan.this_string "ACCEPT" || Scan.this_string "DROP") --| ($$ " ") #> fst;
    val wrap_builtin_chain = (fn (name, policy) => (name, SOME policy));
    val wrap_custom_chain = (fn name => (name, NONE));
  in
    val chain_decl_parser : (string list -> string * string option) =
          Scan.recover (builtin_chain_decl_parser #> wrap_builtin_chain) (K (custom_chain_decl_parser #> wrap_custom_chain));
  end
end;


(*TODO: is there a library function for this?*)
MLlocal
  fun concat [] = []
   | concat (x :: xs) = x @ concat xs;
in
fun Scan_cons_repeat (parser: ('a -> 'b list * 'a)) (s: 'a) : ('b list * 'a) =
    let val (x, rest) = Scan.repeat parser s in (concat x, rest) end;
end

ML_val(Scan_cons_repeat option_parser) (ipt_explode "-i lup -j net-fw")
ML_val(Scan_cons_repeat option_parser) (ipt_explode "")
ML_val(Scan_cons_repeat option_parser) (ipt_explode "-i lup foo")
ML_val(Scan_cons_repeat option_parser) (ipt_explode "-m tcp --dport 22 --sport 88")
ML_val(Scan_cons_repeat option_parser) (ipt_explode "-j LOG --log-prefix \"Shorewall:INPUT:REJECT:\" --log-level 6")


ML_valval (x, rest) = (Scan_cons_repeat option_parser) (ipt_explode "-d 0.31.123.213/11. --foo_bar \"he he\" -f -i eth0+ -s 0.31.123.213/21 moreextra -j foobar --log");
map (fn p => case p of ParsedMatch t => type_of t | ParsedAction (_,_) => dummyT) x;
map (fn p => case p of ParsedMatch t => Pretty.writeln (Syntax.pretty_term @{context} t) | ParsedAction (_,a) => writeln ("action: "^a)) x;

MLlocal
  fun parse_rule_options (s: string list) : parsed_match_action list = let
        val (parsed, rest) = (case try (Scan.catch (Scan_cons_repeat option_parser)) s
                                                                of SOME x => x
                                                                |  NONE   => raise Fail "scanning")
      in
      if rest <> []
      then
        raise Fail ("Unparsed: `"^implode rest^"'")
      else
        parsed
      end
      handle Fail m => raise Fail ("parse_rule_options: "^m^" for rule `"^implode s^"'");

   fun get_target (ps : parsed_match_action list) : (parsed_action_type * string) option = let
        val actions = List.mapPartial (fn p => case p of ParsedAction a => SOME a
                                                      |   _             => NONE) ps
      in case actions of [] => NONE
                      |  [action] => SOME action
                      | _ => raise Fail "there can be at most one target"
      end;

   val get_matches : (parsed_match_action list -> term) =
        List.mapPartial (fn p => case p of
                            ParsedMatch m => SOME (@{const Pos ("128 common_primitive")} $ m)
                          | ParsedNegatedMatch m => SOME (@{const Neg ("128 common_primitive")} $ m)
                          | ParsedAction _ => NONE)
                         #> HOLogic.mk_list @{typ "128 common_primitive negation_type"};


   (*returns: (chainname the rule was appended to, target, matches)*)
   fun parse_rule (s: string) : (string * (parsed_action_type * string) option * term) = let
        val (chainname, rest) =
          (case try (ipt_explode #> Scan.finite Symbol.stopper parse_table_append) s
                                    of SOME x => x
                                    |  NONE   => raise Fail ("parse_rule: parse_table_append: "^s));
        val parsed = parse_rule_options rest
      in (chainname, get_target parsed, get_matches parsed) end;
in
  (*returns (parsed chain declarations, parsed appended rules*)
  fun rule_type_partition (rs : string list) : ((string * string option) list * (string * (parsed_action_type * string) option * term) list) =
      let
        val (chain_decl, rules) = List.partition (String.isPrefix ":") rs
      in
      if not (List.all (String.isPrefix "-A") rules)
      then
        raise Fail "could not partition rules"
      else
        let val parsed_chain_decls = (case try (map (ipt_explode #> chain_decl_parser)) chain_decl
                      of SOME x => x
                      |  NONE => raise Fail ("could not parse chain declarations: "^implode chain_decl));
            val parsed_rules = map parse_rule rules;
            val  _ = "Parsed "^ Int.toString (length parsed_chain_decls) ^" chain declarations" |> writeln;
            val  _ = "Parsed "^ Int.toString (length parsed_rules) ^" rules" |> writeln;
         in (parsed_chain_decls, parsed_rules) end
      end
   fun get_chain_decls_policy (ls: ((string * string option) list * (string * (parsed_action_type * string) option * term) list)) = fst ls
   fun get_parsed_rules (ls: ((string * string option) list * (string * (parsed_action_type * string) option * term) list)) = snd ls
   val filter_chain_decls_names_only :
         ((string * string option) list * (string * (parsed_action_type * string) option * term) list) ->
           (string list * (string * (parsed_action_type * string) option * term) list) = (fn (a,b) => (map fst a, b))
end;


ML(*create a table with the firewall definition*)
structure FirewallTable = Table(type key = string; val ord = Library.string_ord);
type firewall_table = term list FirewallTable.table;

local
  (* Initialize the table. Create a key for every declared chain. *)
  fun FirewallTable_init chain_decls : firewall_table = FirewallTable.empty
            |> fold (fn entry => fn accu => FirewallTable.update_new (entry, []) accu) chain_decls;

  (* this takes like forever! *)
  (* apply compress_parsed_extra here?*)
  fun hacky_hack t = (*Code_Evaluation.dynamic_value_strict @{context} (@{const compress_extra} $ t)*)
    @{const alist_and' ("128 common_primitive")} $ (@{const fill_l4_protocol (128)} $ (@{const compress_parsed_extra (128)} $ t))

  fun mk_MatchExpr t = if fastype_of t <> @{typ "128 common_primitive negation_type list"}
                       then
                         raise Fail "Type Error"
                       else
                         hacky_hack t;
  fun mk_Rule_help t a = let val r = @{const Rule ("128 common_primitive")} $ (mk_MatchExpr t) $ a in
      if fastype_of r <> @{typ "128 common_primitive rule"} then raise Fail "Type error in mk_Rule_help"
      else r end;

  fun append table chain rule = case FirewallTable.lookup table chain
      of NONE => raise Fail ("uninitialized cahin: "^chain)
      |  SOME rules => FirewallTable.update (chain, rules@[rule]) table

  fun mk_Rule (tbl: firewall_table) (chain: string, target : (parsed_action_type * string) option, t : term) =
    if not (FirewallTable.defined tbl chain)
    then
      raise Fail ("undefined chain to be appended: "^chain)
    else case target
    of NONE => mk_Rule_help t @{const action.Empty}
     | SOME (TypeCall, "ACCEPT") => mk_Rule_help t @{const action.Accept}
     | SOME (TypeCall, "DROP") => mk_Rule_help t @{const action.Drop}
     | SOME (TypeCall, "REJECT") => mk_Rule_help t @{const action.Reject}
     | SOME (TypeCall, "LOG") => mk_Rule_help t @{const action.Log}
     | SOME (TypeCall, "RETURN") => mk_Rule_help t @{const action.Return}
     | SOME (TypeCall, custom) => if not (FirewallTable.defined tbl custom)
                                  then
                                    raise Fail ("unknown action: "^custom)
                                  else
                                    mk_Rule_help t (@{const action.Call} $ HOLogic.mk_string custom)
     | SOME (TypeGoto, "ACCEPT") => raise Fail "Unexpected"
     | SOME (TypeGoto, "DROP") => raise Fail "Unexpected"
     | SOME (TypeGoto, "REJECT") => raise Fail "Unexpected"
     | SOME (TypeGoto, "LOG") => raise Fail "Unexpected"
     | SOME (TypeGoto, "RETURN") => raise Fail "Unexpected"
     | SOME (TypeGoto, custom) => if not (FirewallTable.defined tbl custom)
                                  then
                                    raise Fail ("unknown action: "^custom)
                                  else
                                    mk_Rule_help t (@{const action.Goto} $ HOLogic.mk_string custom);

  (*val init = FirewallTable_init parsed_chain_decls;*)
  (*map type_of (map (mk_Rule init) parsed_rules);*)

in
  local
    fun append_rule (tbl: firewall_table) (chain: string, target : (parsed_action_type * string) option, t : term) = append tbl chain (mk_Rule tbl (chain, target, t))
  in
    fun make_firewall_table (parsed_chain_decls : string list, parsed_rules : (string * (parsed_action_type * string) option * term) list) =
      fold (fn rule => fn accu => append_rule accu rule) parsed_rules (FirewallTable_init parsed_chain_decls);
  end
end


MLfun mk_Ruleset (tbl: firewall_table) = FirewallTable.dest tbl
    |> map (fn (k,v) => HOLogic.mk_prod (HOLogic.mk_string k, HOLogic.mk_list @{typ "128 common_primitive rule"} v))
    |> HOLogic.mk_list @{typ "string × 128 common_primitive rule list"}


(*default policies*)
MLlocal
  fun default_policy_action_to_term "ACCEPT" = @{const "action.Accept"}
   |  default_policy_action_to_term "DROP" = @{const "action.Drop"}
   |  default_policy_action_to_term a = raise Fail ("Not a valid default policy `"^a^"'")
in
  (*chain_name * default_policy*)
  fun preparedefault_policies [] = []
   |  preparedefault_policies ((chain_name, SOME default_policy)::ls) =
          (chain_name, default_policy_action_to_term default_policy) :: preparedefault_policies ls
   |  preparedefault_policies ((_, NONE)::ls) = preparedefault_policies ls
end


MLfun trace_timing (printstr : string) (f : 'a -> 'b) (a : 'a) : 'b =
  let val t0 = Time.now(); in
    let val result =  f a; in
    let val t1= Time.now(); in
    let val _ = writeln(String.concat [printstr^" (", Time.toString(Time.-(t1,t0)), " seconds)"]) in
      result
    end end end end;

fun simplify_code ctxt = let val _ = writeln "unfolding (this may take a while) ..." in
      trace_timing "Simplified term" (Code_Evaluation.dynamic_value_strict ctxt)
    end

fun certify_term ctxt t = trace_timing "Certified term" (Thm.cterm_of ctxt) t


ML_val(*Example: putting it all together*)
fun parse_iptables_save_global thy (file: string list) : term =
    load_filter_table thy file
    |> rule_type_partition
    |> filter_chain_decls_names_only
    |> make_firewall_table
    |> mk_Ruleset
    |> simplify_code @{context}

(*
val example = parse_iptables_save @{theory} ["Parser_Test", "data", "iptables-save"];

Pretty.writeln (Syntax.pretty_term @{context} example);*)


MLlocal
  fun define_const t name lthy = let
      val binding_name = Thm.def_binding name
      val _ = writeln ("Defining constant `" ^ Binding.name_of binding_name ^ "'");
    in
      lthy
      (*without Proof_Context.set_stmt, there is an ML stack overflow for large iptables-save dumps*)
      (*Debugged by Makarius, Isabelle2016*)
      |> Proof_Context.set_stmt false  (* FIXME workaround "context begin" oddity *)
      |> Local_Theory.define ((name, NoSyn), ((binding_name, @{attributes [code]}), t)) |> #2
    end;

  fun print_default_policies (ps: (string * term) list) = let
      val _ = ps |> map (fn (name, _) =>
              if name <> "INPUT" andalso name <> "FORWARD" andalso name <> "OUTPUT"
              then
                writeln ("WARNING: the chain `"^name^"' is not a built-in chain of the filter table")
              else ())
      in ps end;

  fun sanity_check_ruleset ctxt t = let
      val check = Code_Evaluation.dynamic_value_strict ctxt (@{const sanity_wf_ruleset ("128 common_primitive")} $ t)
    in
      if check <> @{term "True"} then raise ERROR "sanity_wf_ruleset failed" else t
    end;
in
  fun parse_iptables_save table name path lthy =
    let
      val prepared = path
            |> load_table table (Proof_Context.theory_of lthy)
            |> rule_type_partition
      val firewall = prepared
            |> filter_chain_decls_names_only
            |> make_firewall_table
            |> mk_Ruleset
            (*this may a while*)
            |> simplify_code lthy (*was: @{context} (*TODO: is this correct here?*)*)
            |> trace_timing "checked sanity with sanity_wf_ruleset" (sanity_check_ruleset lthy)
      val default_policis = prepared
            |> get_chain_decls_policy
            |> preparedefault_policies
            |> print_default_policies
    in
      lthy
      |> define_const firewall name
      |> fold (fn (chain_name, policy) =>
            define_const policy (Binding.name (Binding.name_of name ^ "_" ^ chain_name ^ "_default_policy")))
          default_policis
    end
end


MLOuter_Syntax.local_theory @{command_keyword parse_ip6tables_save}
  "load a file generated by iptables-save and make the firewall definition available as isabelle term"
    (Parse.binding --| @{keyword "="} -- Scan.repeat1 Parse.path >>
      (fn (binding, paths) => parse_iptables_save "filter" binding paths))


end

Theory No_Spoof_Embeddings

theory No_Spoof_Embeddings
imports Semantics_Embeddings
        "Primitive_Matchers/No_Spoof"
begin


section‹Spoofing protection in Ternary Semantics implies Spoofing protection Boolean Semantics›
text‹If @{const no_spoofing} is shown in the ternary semantics, it implies that no spoofing
        is possible in the Boolean semantics with magic oracle.
        We only assume that the oracle agrees with the @{const common_matcher} on the not-unknown parts.›
  lemma approximating_imp_booloan_semantics_nospoofing: 
      assumes "matcher_agree_on_exact_matches γ common_matcher"
      and "simple_ruleset rs"
      and no_spoofing: "no_spoofing TYPE('pkt_ext) ipassmt rs"
      shows " iface  dom ipassmt. p::('i::len,'pkt_ext) tagged_packet_scheme.
                (Γ,γ,pp_iiface:=iface_sel iface rs, Undecided  Decision FinalAllow) 
                    p_src p  (ipcidr_union_set (set (the (ipassmt iface))))"
      unfolding no_spoofing_def
      proof(intro ballI allI impI)
        fix iface p
        assume i: "iface  dom ipassmt"
           and a: "Γ,γ,pp_iiface := iface_sel iface rs, Undecided  Decision FinalAllow"

        from no_spoofing[unfolded no_spoofing_def] i have no_spoofing':
          "(common_matcher, in_doubt_allow),pp_iiface := iface_sel iface rs, Undecided α Decision FinalAllow 
           p_src p  ipcidr_union_set (set (the (ipassmt iface)))" by blast

        from assms simple_imp_good_ruleset FinalAllows_subseteq_in_doubt_allow[where rs=rs] have
          "{p. Γ,γ,p rs, Undecided  Decision FinalAllow}  {p. (common_matcher, in_doubt_allow),p rs, Undecided α Decision FinalAllow}" 
          by blast
        with a have "(common_matcher, in_doubt_allow),pp_iiface := iface_sel iface rs, Undecided α Decision FinalAllow" by blast
        with no_spoofing' show "p_src p  ipcidr_union_set (set (the (ipassmt iface)))"by blast
      qed

 (*expressed as set*)
  corollary
      assumes "matcher_agree_on_exact_matches γ common_matcher" and "simple_ruleset rs"
          and no_spoofing: "no_spoofing TYPE('pkt_ext) ipassmt rs" and "iface  dom ipassmt"
      shows "{p_src p | p :: ('i::len,'pkt_ext) tagged_packet_scheme. (Γ,γ,pp_iiface:=iface_sel iface rs, Undecided  Decision FinalAllow)} 
                 ipcidr_union_set (set (the (ipassmt iface)))"
      using approximating_imp_booloan_semantics_nospoofing[OF assms(1) assms(2) assms(3), where Γ=Γ]
      using assms(4) by blast


 (*expressed as set*)
  corollary no_spoofing_executable_set:
      assumes "matcher_agree_on_exact_matches γ common_matcher"
          and "simple_ruleset rs"
          and "rset rs. normalized_nnf_match (get_match r)"
          and no_spoofing_executable: "iface  dom ipassmt. no_spoofing_iface iface ipassmt rs"
          and "iface  dom ipassmt"
      shows "{p_src p | p :: ('i::len,'pkt_ext) tagged_packet_scheme. (Γ,γ,pp_iiface:=iface_sel iface rs, Undecided  Decision FinalAllow)} 
                 ipcidr_union_set (set (the (ipassmt iface)))"
  proof -
    { assume no_spoofing: "no_spoofing TYPE('pkt_ext) ipassmt rs"
      have "{p_src p | p :: ('i,'pkt_ext) tagged_packet_scheme. (Γ,γ,pp_iiface:=iface_sel iface rs, Undecided  Decision FinalAllow)} 
                 ipcidr_union_set (set (the (ipassmt iface)))"
      using approximating_imp_booloan_semantics_nospoofing[OF assms(1) assms(2) no_spoofing, where Γ=Γ]
      using assms(5) by blast
    }
    with no_spoofing_iface[OF assms(2) assms(3) no_spoofing_executable] show ?thesis by blast
  qed


  corollary no_spoofing_executable_set_preprocessed:
      fixes ipassmt :: "'i::len ipassignment"
      defines "preprocess rs  upper_closure (packet_assume_new rs)"
          and "newpkt p  match_tcp_flags ipt_tcp_syn (p_tcp_flags p)  p_tag_ctstate p = CT_New"
      assumes "matcher_agree_on_exact_matches γ common_matcher"
          and simplers: "simple_ruleset rs"
          and no_spoofing_executable: "iface  dom ipassmt. no_spoofing_iface iface ipassmt (preprocess rs)"
          and "iface  dom ipassmt"
      shows "{p_src p | p :: ('i::len,'pkt_ext) tagged_packet_scheme. newpkt p  Γ,γ,pp_iiface:=iface_sel iface rs, Undecided  Decision FinalAllow} 
                 ipcidr_union_set (set (the (ipassmt iface)))"
  proof -
   have newpktD: "newpkt p  newpkt (pp_iiface := iface_sel iface)" for p
     by(simp add: newpkt_def)
   from packet_assume_new_simple_ruleset[OF simplers] have s1: "simple_ruleset (packet_assume_new rs)" .
   from transform_upper_closure(2)[OF s1] have s2: "simple_ruleset (upper_closure (packet_assume_new rs))" .
   hence s2': "simple_ruleset (preprocess rs)" unfolding preprocess_def by simp
   have "rset (preprocess rs). normalized_nnf_match (get_match r)"
     unfolding preprocess_def
     using transform_upper_closure(3)[OF s1] by simp

   from no_spoofing_iface[OF s2' this no_spoofing_executable] have nospoof: "no_spoofing TYPE('a) ipassmt (preprocess rs)" .

   from assms(3) have 1: "{p. Γ,γ,p rs, Undecided  Decision FinalAllow  newpkt p} 
                       {p. (common_matcher, in_doubt_allow),p rs, Undecided α Decision FinalAllow  newpkt p}"
    apply(drule_tac rs=rs and Γ=Γ in FinalAllows_subseteq_in_doubt_allow)
     using simple_imp_good_ruleset assms(4) apply blast
    by blast
   have 2: "{p. (common_matcher, in_doubt_allow),p rs, Undecided α Decision FinalAllow  newpkt p} 
         {p. (common_matcher, in_doubt_allow),p preprocess rs, Undecided α Decision FinalAllow  newpkt p}"
     unfolding newpkt_def preprocess_def
     apply(subst transform_upper_closure(1)[OF s1])
     apply(subst approximating_semantics_iff_fun_good_ruleset[OF simple_imp_good_ruleset[OF s1]])
     apply(subst approximating_semantics_iff_fun_good_ruleset[OF simple_imp_good_ruleset[OF simplers]])
     using packet_assume_new newpkt_def by force
   from 1 2 have "{p. Γ,γ,p rs, Undecided  Decision FinalAllow  newpkt p} 
         {p. (common_matcher, in_doubt_allow),p preprocess rs, Undecided α Decision FinalAllow  newpkt p}" by simp
   hence p: "Γ,γ,p rs, Undecided  Decision FinalAllow  newpkt p 
           (common_matcher, in_doubt_allow),p preprocess rs, Undecided α Decision FinalAllow  newpkt p" for p by blast
   have x: "{p_src p | p . newpkt p  (Γ,γ,pp_iiface:=iface_sel iface rs, Undecided  Decision FinalAllow)} 
            {p_src p | p . newpkt p  (common_matcher, in_doubt_allow),pp_iiface:=iface_sel iface preprocess rs, Undecided α Decision FinalAllow}"
     apply(safe, rename_tac p)
     apply(drule newpktD)
     apply(rule_tac x="pp_iiface := iface_sel iface" in exI)
     using p by simp
   note[[show_types]]
   with nospoof have y: 
    "{p_src p | p :: ('i::len,'pkt_ext) tagged_packet_scheme. newpkt p  (common_matcher, in_doubt_allow),pp_iiface:=iface_sel iface preprocess rs, Undecided α Decision FinalAllow}
     ipcidr_union_set (set (the (ipassmt iface)))"
    apply(simp add: no_spoofing_def)
    by(blast dest: bspec[OF _ assms(6)])
   from x y show ?thesis by simp
  qed

end

Theory Parser

section‹Parser for iptables-save›
theory Parser
imports Code_Interface
  keywords "parse_iptables_save" :: thy_decl
begin


ML(*my personal small library*)
fun takeWhile p xs = take_prefix p xs;

fun dropWhile p xs = drop_prefix p xs;

fun dropWhileInclusive p xs = drop 1 (dropWhile p xs)

(*split at the predicate, do NOT keep the position where it was split*)
fun split_at p xs = (takeWhile p xs, dropWhileInclusive p xs);

ML_valsplit_at (fn x => x <> " ") (raw_explode "foo bar")


section‹An SML Parser for iptables-save›
text‹Work in Progress›

MLlocal
  fun is_start_of_table table s = s = ("*"^table);
  fun is_end_of_table s = s = "COMMIT";

  fun load_file (thy: theory) (path: string list) =
      let val p =  File.full_path (Resources.master_directory thy) (Path.make path);
          val _ = "loading file "^File.platform_path p |> writeln;
      in
        if
          not (File.exists p) orelse (File.is_dir p)
        then
          raise Fail "File not found"
        else
          File.read_lines p
      end;

  fun extract_table _ [] = []
   |  extract_table table (r::rs) = if not (is_start_of_table table r)
                                    then
                                      extract_table table rs
                                    else
                                      takeWhile (fn x => not (is_end_of_table x)) rs;

  fun writenumloaded table_name table = let
      val _ = "Loaded "^ Int.toString (length table) ^" lines of the "^table_name^" table" |> writeln;
    in table end;

  fun warn_windows_line_endings lines =
    let
      val warn = fn s => if String.isSuffix "\r" s
                         then
                           writeln "WARNING: windows \\r\\n line ending detected"
                         else
                           ()
      val _ = map warn lines
    in
      lines
    end;
in
  fun load_table table thy = load_file thy
      #> warn_windows_line_endings
      #> extract_table table
      #> writenumloaded table;
  val load_filter_table = load_table "filter";
end;


ML(*keep quoted strings as one token*)
local
  fun collapse_quotes [] = []
   |  collapse_quotes ("\""::ss) = let val (quoted, rest) = split_at (fn x => x <> "\"") ss in
                                          "\"" ^ implode quoted^"\"" :: rest end
   |  collapse_quotes (s::ss) = s :: collapse_quotes ss;
in
  val ipt_explode = raw_explode #> collapse_quotes;
end
ML_valipt_explode "ad \"as das\" boo";
ipt_explode "ad \"foobar --boo boo";
ipt_explode "ent \"\\\"\" this";
ipt_explode "";


(*
ML_val‹
fun finite_scan scan = Scan.error (Scan.finite Symbol.stopper (scan));
finite_scan
     ((Scan.this_string "foo") --|
      (Scan.ahead ($$ " " || Scan.one Symbol.is_eof))) (raw_explode "foo ");
›
ML‹
local
  val errormsg = (fn (ss, _) => raise Fail ("parse error: expected word boundary near `"^implode ss^"'"))
  fun finite_scan scanner = (Scan.finite Symbol.stopper (Scan.error (!! errormsg scanner)));
  val word_boundary_or_end = Scan.ahead ($$ " " || Scan.one Symbol.is_eof)
in
  fun look_ahead_token (scan : (string list -> 'a * string list)) s = (*TODO: why do I need to write the type?*)
          finite_scan (scan --| word_boundary_or_end) s;
end;
val _ = look_ahead_token (Scan.this_string "foo") (raw_explode "foo ");
val _ = look_ahead_token (Scan.this_string "foo") (raw_explode "foo");
val _ = (look_ahead_token (Scan.this_string "foo")) (raw_explode "fo")
  handle Fail m => if m = "parse error: expected word boundary near `fo'" then ("", [])
                   else raise Fail "foo";
›*)

MLdatatype parsed_action_type = TypeCall | TypeGoto
datatype parsed_match_action = ParsedMatch of term
                             | ParsedNegatedMatch of term
                             | ParsedAction of parsed_action_type * string;

local (*iptables-save parsers*)
  val is_whitespace = Scan.many (fn x => x = " ");

  local (*parser for matches*)
    local
      fun extract_int ss = case ss |> implode |> Int.fromString
                                                    of SOME i => i
                                                    |  NONE   => raise Fail "unparsable int";

      fun is_iface_char x = Symbol.is_ascii x andalso
            (Symbol.is_ascii_letter x orelse Symbol.is_ascii_digit x orelse x = "+"
             orelse x = "*" orelse x = "." orelse x = "-")
    in
      fun mk_nat maxval i = if i < 0 orelse i > maxval
                then
                  raise Fail("nat ("^Int.toString i^") must be between 0 and "^Int.toString maxval)
                else (HOLogic.mk_number HOLogic.natT i);

      fun ipNetmask_to_hol (ip,len) = @{const IpAddrNetmask (32)} $ mk_ipv4addr ip $ mk_nat 32 len;
      fun ipRange_to_hol (ip1,ip2) = @{const IpAddrRange (32)} $ mk_ipv4addr ip1 $ mk_ipv4addr ip2;


      val parser_ip_cidr = parser_ipv4 --| ($$ "/") -- (Scan.many1 Symbol.is_ascii_digit >> extract_int) >> ipNetmask_to_hol;

      val parser_ip_range = parser_ipv4 --| ($$ "-") -- parser_ipv4 >> ipRange_to_hol;

      val parser_ip_addr = parser_ipv4 >> (fn ip => @{const IpAddr (32)} $ mk_ipv4addr ip);

      val parser_interface = Scan.many1 is_iface_char >> (implode #> (fn x => @{const Iface} $ HOLogic.mk_string x));

       (*TODO: it would be cool to check for a word boundary after all these strings*)
      val parser_protocol = Scan.this_string "tcp" >> K @{term "TCP :: 8 word"}
                         || Scan.this_string "udp" >> K @{term "UDP :: 8 word"}
                         || (Scan.this_string "icmpv6" (*before icmp*) || Scan.this_string "ipv6-icmp")
                              >> K @{term "L4_Protocol.IPv6ICMP"}
                         || Scan.this_string "icmp" >> K @{term "ICMP :: 8 word"}
                         (*Moar Assigned Internet Protocol Numbers below: *)
                         || Scan.this_string "esp" >> K @{term "L4_Protocol.ESP"}
                         || Scan.this_string "ah" >> K @{term "L4_Protocol.AH"}
                         || Scan.this_string "gre" >> K @{term "L4_Protocol.GRE"}

      val parser_ctstate = Scan.this_string "NEW" >> K @{const CT_New}
                         || Scan.this_string "ESTABLISHED" >> K @{const CT_Established}
                         || Scan.this_string "RELATED" >> K @{const CT_Related}
                         || Scan.this_string "UNTRACKED" >> K @{const CT_Untracked}
                         || Scan.this_string "INVALID" >> K @{const CT_Invalid}

      val parser_tcp_flag = Scan.this_string "SYN" >> K @{const TCP_SYN}
                         || Scan.this_string "ACK" >> K @{const TCP_ACK}
                         || Scan.this_string "FIN" >> K @{const TCP_FIN}
                         || Scan.this_string "RST" >> K @{const TCP_RST}
                         || Scan.this_string "URG" >> K @{const TCP_URG}
                         || Scan.this_string "PSH" >> K @{const TCP_PSH}

      fun parse_comma_separated_list parser = Scan.repeat (parser --| $$ ",") @@@ (parser >> (fn p => [p]))

      local
        val mk_port_single = mk_nat 65535 #> (fn n => @{const nat_to_16word} $ n)
        val parse_port_raw = Scan.many1 Symbol.is_ascii_digit >> extract_int
        fun port_tuple_warn (p1,p2) =
                if p1 >= p2
                then
                  let val _= writeln ("WARNING (in ports): "^Int.toString p1^" >= "^Int.toString p2)
                  in (p1, p2) end
                else (p1, p2);
      in
        val parser_port_single_tup = (
                 (parse_port_raw --| $$ ":" -- parse_port_raw)
                    >> (port_tuple_warn #> (fn (p1,p2) => (mk_port_single p1, mk_port_single p2)))
              || (parse_port_raw  >> (fn p => (mk_port_single p, mk_port_single p)))
            ) >> HOLogic.mk_prod
        end
      val parser_port_single_tup_term = parser_port_single_tup
            >> (fn x => @{term "L4Ports 0"} $ HOLogic.mk_list @{typ "16 word × 16 word"} [x])

      val parser_port_many1_tup = parse_comma_separated_list parser_port_single_tup
            >> (fn x => @{term "L4Ports 0"} $ HOLogic.mk_list @{typ "16 word × 16 word"} x)

      val parser_ctstate_set = parse_comma_separated_list parser_ctstate
            >> HOLogic.mk_set @{typ "ctstate"}

      val parser_tcp_flag_set = parse_comma_separated_list parser_tcp_flag
            >> HOLogic.mk_set @{typ "tcp_flag"}

      val parser_tcp_flags = (parser_tcp_flag_set --| $$ " " -- parser_tcp_flag_set)
            >> (fn (m,c) => @{const TCP_Flags} $ m $ c)

      val parser_extra = Scan.many1 (fn x => x <> " " andalso Symbol.not_eof x)
            >> (implode #> HOLogic.mk_string);
    end;
    val eoo = Scan.ahead ($$ " " || Scan.one Symbol.is_eof); (*end of option; word boundary or eof look-ahead*)

    fun parse_cmd_option_generic (d: term -> parsed_match_action) s t (parser: string list -> (term * string list)) =
        Scan.finite Symbol.stopper (is_whitespace |-- Scan.this_string s |-- (parser >> (fn r => d (t $ r))) --| eoo)

    fun parse_cmd_option (s: string) (t: term) (parser: string list -> (term * string list)) =
            parse_cmd_option_generic ParsedMatch s t parser;

    (*both negated and not negated primitives*)
    fun parse_cmd_option_negated (s: string) (t: term) (parser: string list -> (term * string list)) =
          parse_cmd_option_generic ParsedNegatedMatch ("! "^s) t parser || parse_cmd_option s t parser;

    fun parse_cmd_option_negated_singleton s t parser = parse_cmd_option_negated s t parser >> (fn x => [x])

    (*TODO: is the 'Scan.finite Symbol.stopper' correct here?*)
    (*TODO: eoo here?*)
    fun parse_with_module_prefix (module: string) (parser: (string list -> parsed_match_action * string list)) =
      (Scan.finite Symbol.stopper (is_whitespace |-- Scan.this_string module)) |-- (Scan.repeat parser)
  in

    val parse_ips = parse_cmd_option_negated_singleton "-s " @{const Src (32)} (parser_ip_cidr || parser_ip_addr)
                 || parse_cmd_option_negated_singleton "-d " @{const Dst (32)} (parser_ip_cidr || parser_ip_addr);


    val parse_iprange = parse_with_module_prefix "-m iprange "
                            (   parse_cmd_option_negated "--src-range " @{const Src (32)} parser_ip_range
                             || parse_cmd_option_negated "--dst-range " @{const Dst (32)} parser_ip_range);

    val parse_iface = parse_cmd_option_negated_singleton "-i " @{const IIface (32)} parser_interface
                   || parse_cmd_option_negated_singleton "-o " @{const OIface (32)} parser_interface;

    (*TODO type is explicit here*)
    val parse_protocol = parse_cmd_option_negated_singleton "-p "
                @{term "(Prot  Proto) :: primitive_protocol  32 common_primitive"} parser_protocol; (*negated?*)

    (*-m tcp requires that there is already an -p tcp, iptables checks that for you,
      we assume valid iptables-save (otherwise the kernel would not load it)
      We will fill the protocols in the L4Ports later*)
    val parse_tcp_options = parse_with_module_prefix "-m tcp "
              (   parse_cmd_option_negated "--sport " @{const Src_Ports (32)} parser_port_single_tup_term
               || parse_cmd_option_negated "--dport " @{const Dst_Ports (32)} parser_port_single_tup_term
               || parse_cmd_option_negated "--tcp-flags " @{const L4_Flags (32)} parser_tcp_flags);
    val parse_multiports = parse_with_module_prefix "-m multiport "
              (   parse_cmd_option_negated "--sports " @{const Src_Ports (32)} parser_port_many1_tup
               || parse_cmd_option_negated "--dports " @{const Dst_Ports (32)} parser_port_many1_tup
               || parse_cmd_option_negated "--ports " @{const MultiportPorts (32)} parser_port_many1_tup);
    val parse_udp_options = parse_with_module_prefix "-m udp "
              (   parse_cmd_option_negated "--sport " @{const Src_Ports (32)} parser_port_single_tup_term
               || parse_cmd_option_negated "--dport " @{const Dst_Ports (32)} parser_port_single_tup_term);

    val parse_ctstate = parse_with_module_prefix "-m state "
                  (parse_cmd_option_negated "--state " @{const CT_State (32)} parser_ctstate_set)
              || parse_with_module_prefix "-m conntrack "
                  (parse_cmd_option_negated "--ctstate " @{const CT_State (32)} parser_ctstate_set);

     (*TODO: it would be good to fail if there is a "!" in the extra; it might be an unparsed negation*)
    val parse_unknown = (parse_cmd_option "" @{const Extra (32)} parser_extra) >> (fn x => [x]);
  end;


  local (*parser for target/action*)
    fun is_target_char x = Symbol.is_ascii x andalso
        (Symbol.is_ascii_letter x orelse Symbol.is_ascii_digit x orelse x = "-" orelse x = "_" orelse x = "~")

    fun parse_finite_skipwhite parser = Scan.finite Symbol.stopper (is_whitespace |-- parser);

    val is_icmp_type = fn x => Symbol.is_ascii_letter x orelse x = "-" orelse x = "6"
  in
    val parser_target = Scan.many1 is_target_char >> implode;

    (*parses: -j MY_CUSTOM_CHAIN*)
    (*The -j may not be the end of the line. example: -j LOG --log-prefix "[IPT_DROP]:"*)
    val parse_target_generic : (string list -> parsed_match_action * string list) =  parse_finite_skipwhite
      (Scan.this_string "-j " |-- (parser_target >> (fn s => ParsedAction (TypeCall, s))));

    (*parses: REJECT --reject-with type*)
    val parse_target_reject : (string list -> parsed_match_action * string list) =  parse_finite_skipwhite
      (Scan.this_string "-j " |-- (Scan.this_string "REJECT" >> (fn s => ParsedAction (TypeCall, s)))
       --| ((Scan.this_string " --reject-with " --| Scan.many1 is_icmp_type) || Scan.this_string ""));


    val parse_target_goto : (string list -> parsed_match_action * string list) = parse_finite_skipwhite
      (Scan.this_string "-g " |-- (parser_target >> (fn s => let val _ = writeln ("WARNING: goto in `"^s^"'") in ParsedAction (TypeGoto, s) end)));

    val parse_target : (string list -> parsed_match_action * string list) = parse_target_reject || parse_target_goto || parse_target_generic;
  end;
in
  (*parses: -A FORWARD*)
  val parse_table_append : (string list -> (string * string list)) = Scan.this_string "-A " |-- parser_target --| is_whitespace;

  (*parses: -s 0.31.123.213/88 --foo_bar -j chain --foobar
   First tries to parse a known field, afterwards, it parses something unknown until a blank space appears
  *)
  val option_parser : (string list -> (parsed_match_action list) * string list) =
      Scan.recover (parse_ips || parse_iprange
                 || parse_iface
                 || parse_protocol
                 || parse_tcp_options || parse_udp_options || parse_multiports
                 || parse_ctstate
                 || parse_target >> (fn x => [x])) (K parse_unknown);


  (*parse_table_append should be called before option_parser, otherwise -A will simply be an unknown for option_parser*)

  local
    (*:DOS_PROTECT - [0:0]*)
    val custom_chain_decl_parser = ($$ ":") |-- parser_target --| Scan.this_string " - " #> fst;
    (*:INPUT ACCEPT [130:12050]*)
    (*TODO: PREROUTING is only valid if we are in the raw table*)
    val builtin_chain_decl_parser = ($$ ":") |--
      (Scan.this_string "INPUT" || Scan.this_string "FORWARD" || Scan.this_string "OUTPUT" || Scan.this_string "PREROUTING") --|
      ($$ " ") -- (Scan.this_string "ACCEPT" || Scan.this_string "DROP") --| ($$ " ") #> fst;
    val wrap_builtin_chain = (fn (name, policy) => (name, SOME policy));
    val wrap_custom_chain = (fn name => (name, NONE));
  in
    val chain_decl_parser : (string list -> string * string option) =
          Scan.recover (builtin_chain_decl_parser #> wrap_builtin_chain) (K (custom_chain_decl_parser #> wrap_custom_chain));
  end
end;


(*TODO: is there a library function for this?*)
MLlocal
  fun concat [] = []
   | concat (x :: xs) = x @ concat xs;
in
fun Scan_cons_repeat (parser: ('a -> 'b list * 'a)) (s: 'a) : ('b list * 'a) =
    let val (x, rest) = Scan.repeat parser s in (concat x, rest) end;
end

ML_val(Scan_cons_repeat option_parser) (ipt_explode "-i lup -j net-fw")
ML_val(Scan_cons_repeat option_parser) (ipt_explode "")
ML_val(Scan_cons_repeat option_parser) (ipt_explode "-i lup foo")
ML_val(Scan_cons_repeat option_parser) (ipt_explode "-m tcp --dport 22 --sport 88")
ML_val(Scan_cons_repeat option_parser) (ipt_explode "-j LOG --log-prefix \"Shorewall:INPUT:REJECT:\" --log-level 6")


ML_valval (x, rest) = (Scan_cons_repeat option_parser) (ipt_explode "-d 0.31.123.213/11. --foo_bar \"he he\" -f -i eth0+ -s 0.31.123.213/21 moreextra -j foobar --log");
map (fn p => case p of ParsedMatch t => type_of t | ParsedAction (_,_) => dummyT) x;
map (fn p => case p of ParsedMatch t => Pretty.writeln (Syntax.pretty_term @{context} t) | ParsedAction (_,a) => writeln ("action: "^a)) x;

MLlocal
  fun parse_rule_options (s: string list) : parsed_match_action list = let
        val (parsed, rest) = (case try (Scan.catch (Scan_cons_repeat option_parser)) s
                                                                of SOME x => x
                                                                |  NONE   => raise Fail "scanning")
      in
      if rest <> []
      then
        raise Fail ("Unparsed: `"^implode rest^"'")
      else
        parsed
      end
      handle Fail m => raise Fail ("parse_rule_options: "^m^" for rule `"^implode s^"'");

   fun get_target (ps : parsed_match_action list) : (parsed_action_type * string) option = let
        val actions = List.mapPartial (fn p => case p of ParsedAction a => SOME a
                                                      |   _             => NONE) ps
      in case actions of [] => NONE
                      |  [action] => SOME action
                      | _ => raise Fail "there can be at most one target"
      end;

   val get_matches : (parsed_match_action list -> term) =
        List.mapPartial (fn p => case p of
                            ParsedMatch m => SOME (@{const Pos ("32 common_primitive")} $ m)
                          | ParsedNegatedMatch m => SOME (@{const Neg ("32 common_primitive")} $ m)
                          | ParsedAction _ => NONE)
                         #> HOLogic.mk_list @{typ "32 common_primitive negation_type"};


   (*returns: (chainname the rule was appended to, target, matches)*)
   fun parse_rule (s: string) : (string * (parsed_action_type * string) option * term) = let
        val (chainname, rest) =
          (case try (ipt_explode #> Scan.finite Symbol.stopper parse_table_append) s
                                    of SOME x => x
                                    |  NONE   => raise Fail ("parse_rule: parse_table_append: "^s));
        val parsed = parse_rule_options rest
      in (chainname, get_target parsed, get_matches parsed) end;
in
  (*returns (parsed chain declarations, parsed appended rules*)
  fun rule_type_partition (rs : string list) : ((string * string option) list * (string * (parsed_action_type * string) option * term) list) =
      let
        val (chain_decl, rules) = List.partition (String.isPrefix ":") rs
      in
      if not (List.all (String.isPrefix "-A") rules)
      then
        raise Fail "could not partition rules"
      else
        let val parsed_chain_decls = (case try (map (ipt_explode #> chain_decl_parser)) chain_decl
                      of SOME x => x
                      |  NONE => raise Fail ("could not parse chain declarations: "^implode chain_decl));
            val parsed_rules = map parse_rule rules;
            val  _ = "Parsed "^ Int.toString (length parsed_chain_decls) ^" chain declarations" |> writeln;
            val  _ = "Parsed "^ Int.toString (length parsed_rules) ^" rules" |> writeln;
         in (parsed_chain_decls, parsed_rules) end
      end
   fun get_chain_decls_policy (ls: ((string * string option) list * (string * (parsed_action_type * string) option * term) list)) = fst ls
   fun get_parsed_rules (ls: ((string * string option) list * (string * (parsed_action_type * string) option * term) list)) = snd ls
   val filter_chain_decls_names_only :
         ((string * string option) list * (string * (parsed_action_type * string) option * term) list) ->
           (string list * (string * (parsed_action_type * string) option * term) list) = (fn (a,b) => (map fst a, b))
end;


ML(*create a table with the firewall definition*)
structure FirewallTable = Table(type key = string; val ord = Library.string_ord);
type firewall_table = term list FirewallTable.table;

local
  (* Initialize the table. Create a key for every declared chain. *)
  fun FirewallTable_init chain_decls : firewall_table = FirewallTable.empty
            |> fold (fn entry => fn accu => FirewallTable.update_new (entry, []) accu) chain_decls;

  (* this takes like forever! *)
  (* apply compress_parsed_extra here?*)
  fun hacky_hack t = (*Code_Evaluation.dynamic_value_strict @{context} (@{const compress_extra} $ t)*)
    @{const alist_and' ("32 common_primitive")} $ (@{const fill_l4_protocol (32)} $ (@{const compress_parsed_extra (32)} $ t))

  fun mk_MatchExpr t = if fastype_of t <> @{typ "32 common_primitive negation_type list"}
                       then
                         raise Fail "Type Error"
                       else
                         hacky_hack t;
  fun mk_Rule_help t a = let val r = @{const Rule ("32 common_primitive")} $ (mk_MatchExpr t) $ a in
      if fastype_of r <> @{typ "32 common_primitive rule"} then raise Fail "Type error in mk_Rule_help"
      else r end;

  fun append table chain rule = case FirewallTable.lookup table chain
      of NONE => raise Fail ("uninitialized cahin: "^chain)
      |  SOME rules => FirewallTable.update (chain, rules@[rule]) table

  fun mk_Rule (tbl: firewall_table) (chain: string, target : (parsed_action_type * string) option, t : term) =
    if not (FirewallTable.defined tbl chain)
    then
      raise Fail ("undefined chain to be appended: "^chain)
    else case target
    of NONE => mk_Rule_help t @{const action.Empty}
     | SOME (TypeCall, "ACCEPT") => mk_Rule_help t @{const action.Accept}
     | SOME (TypeCall, "DROP") => mk_Rule_help t @{const action.Drop}
     | SOME (TypeCall, "REJECT") => mk_Rule_help t @{const action.Reject}
     | SOME (TypeCall, "LOG") => mk_Rule_help t @{const action.Log}
     | SOME (TypeCall, "RETURN") => mk_Rule_help t @{const action.Return}
     | SOME (TypeCall, custom) => if not (FirewallTable.defined tbl custom)
                                  then
                                    raise Fail ("unknown action: "^custom)
                                  else
                                    mk_Rule_help t (@{const action.Call} $ HOLogic.mk_string custom)
     | SOME (TypeGoto, "ACCEPT") => raise Fail "Unexpected"
     | SOME (TypeGoto, "DROP") => raise Fail "Unexpected"
     | SOME (TypeGoto, "REJECT") => raise Fail "Unexpected"
     | SOME (TypeGoto, "LOG") => raise Fail "Unexpected"
     | SOME (TypeGoto, "RETURN") => raise Fail "Unexpected"
     | SOME (TypeGoto, custom) => if not (FirewallTable.defined tbl custom)
                                  then
                                    raise Fail ("unknown action: "^custom)
                                  else
                                    mk_Rule_help t (@{const action.Goto} $ HOLogic.mk_string custom);

  (*val init = FirewallTable_init parsed_chain_decls;*)
  (*map type_of (map (mk_Rule init) parsed_rules);*)

in
  local
    fun append_rule (tbl: firewall_table) (chain: string, target : (parsed_action_type * string) option, t : term) = append tbl chain (mk_Rule tbl (chain, target, t))
  in
    fun make_firewall_table (parsed_chain_decls : string list, parsed_rules : (string * (parsed_action_type * string) option * term) list) =
      fold (fn rule => fn accu => append_rule accu rule) parsed_rules (FirewallTable_init parsed_chain_decls);
  end
end


MLfun mk_Ruleset (tbl: firewall_table) = FirewallTable.dest tbl
    |> map (fn (k,v) => HOLogic.mk_prod (HOLogic.mk_string k, HOLogic.mk_list @{typ "32 common_primitive rule"} v))
    |> HOLogic.mk_list @{typ "string × 32 common_primitive rule list"}


(*default policies*)
MLlocal
  fun default_policy_action_to_term "ACCEPT" = @{const "action.Accept"}
   |  default_policy_action_to_term "DROP" = @{const "action.Drop"}
   |  default_policy_action_to_term a = raise Fail ("Not a valid default policy `"^a^"'")
in
  (*chain_name * default_policy*)
  fun preparedefault_policies [] = []
   |  preparedefault_policies ((chain_name, SOME default_policy)::ls) =
          (chain_name, default_policy_action_to_term default_policy) :: preparedefault_policies ls
   |  preparedefault_policies ((_, NONE)::ls) = preparedefault_policies ls
end


MLfun trace_timing (printstr : string) (f : 'a -> 'b) (a : 'a) : 'b =
  let val t0 = Time.now(); in
    let val result =  f a; in
    let val t1= Time.now(); in
    let val _ = writeln(String.concat [printstr^" (", Time.toString(Time.-(t1,t0)), " seconds)"]) in
      result
    end end end end;

fun simplify_code ctxt = let val _ = writeln "unfolding (this may take a while) ..." in
      trace_timing "Simplified term" (Code_Evaluation.dynamic_value_strict ctxt)
    end

fun certify_term ctxt t = trace_timing "Certified term" (Thm.cterm_of ctxt) t


ML_val(*Example: putting it all together*)
fun parse_iptables_save_global thy (file: string list) : term =
    load_filter_table thy file
    |> rule_type_partition
    |> filter_chain_decls_names_only
    |> make_firewall_table
    |> mk_Ruleset
    |> simplify_code @{context}

(*
val example = parse_iptables_save @{theory} ["Parser_Test", "data", "iptables-save"];

Pretty.writeln (Syntax.pretty_term @{context} example);*)


MLlocal
  fun define_const t name lthy = let
      val binding_name = Thm.def_binding name
      val _ = writeln ("Defining constant `" ^ Binding.name_of binding_name ^ "'");
    in
      lthy
      (*without Proof_Context.set_stmt, there is an ML stack overflow for large iptables-save dumps*)
      (*Debugged by Makarius, Isabelle2016*)
      |> Proof_Context.set_stmt false  (* FIXME workaround "context begin" oddity *)
      |> Local_Theory.define ((name, NoSyn), ((binding_name, @{attributes [code]}), t)) |> #2
    end;

  fun print_default_policies (ps: (string * term) list) = let
      val _ = ps |> map (fn (name, _) =>
              if name <> "INPUT" andalso name <> "FORWARD" andalso name <> "OUTPUT"
              then
                writeln ("WARNING: the chain `"^name^"' is not a built-in chain of the filter table")
              else ())
      in ps end;

  fun sanity_check_ruleset ctxt t = let
      val check = Code_Evaluation.dynamic_value_strict ctxt (@{const sanity_wf_ruleset ("32 common_primitive")} $ t)
    in
      if check <> @{term "True"} then raise ERROR "sanity_wf_ruleset failed" else t
    end;
in
  fun parse_iptables_save table name path lthy =
    let
      val prepared = path
            |> load_table table (Proof_Context.theory_of lthy)
            |> rule_type_partition
      val firewall = prepared
            |> filter_chain_decls_names_only
            |> make_firewall_table
            |> mk_Ruleset
            (*this may a while*)
            |> simplify_code lthy (*was: @{context} (*TODO: is this correct here?*)*)
            |> trace_timing "checked sanity with sanity_wf_ruleset" (sanity_check_ruleset lthy)
      val default_policis = prepared
            |> get_chain_decls_policy
            |> preparedefault_policies
            |> print_default_policies
    in
      lthy
      |> define_const firewall name
      |> fold (fn (chain_name, policy) =>
            define_const policy (Binding.name (Binding.name_of name ^ "_" ^ chain_name ^ "_default_policy")))
          default_policis
    end
end


MLOuter_Syntax.local_theory @{command_keyword parse_iptables_save}
  "load a file generated by iptables-save and make the firewall definition available as isabelle term"
    (Parse.binding --| @{keyword "="} -- Scan.repeat1 Parse.path >>
      (fn (binding, paths) => parse_iptables_save "filter" binding paths))


end

Theory Code_haskell

theory Code_haskell
imports
  Routing.IpRoute_Parser
  "Primitive_Matchers/Parser"
begin

definition word_less_eq :: "('a::len) word  ('a::len) word  bool" where
  "word_less_eq a b  a  b"

definition word_to_nat :: "('a::len) word  nat" where
  "word_to_nat = Word.unat"


definition mk_Set :: "'a list  'a set" where
  "mk_Set = set"

text‹Assumes that you call @{const fill_l4_protocol} after parsing!›
definition mk_L4Ports_pre :: "raw_ports  ipt_l4_ports" where
  "mk_L4Ports_pre ports_raw = L4Ports 0 ports_raw"


fun ipassmt_iprange_translate :: "'i::len ipt_iprange list negation_type  ('i word × nat) list" where
  "ipassmt_iprange_translate (Pos ips) = concat (map ipt_iprange_to_cidr ips)" |
  "ipassmt_iprange_translate (Neg ips) = all_but_those_ips (concat (map ipt_iprange_to_cidr ips))"

definition to_ipassmt
  :: "(iface × 'i::len ipt_iprange list negation_type) list  (iface × ('i word × nat) list) list" where
  "to_ipassmt assmt = map (λ(ifce, ips). (ifce, ipassmt_iprange_translate ips)) assmt"

definition "zero_word  0 :: ('a :: len) word"

export_code Rule
  Match MatchNot MatchAnd MatchAny
  Src Dst IIface OIface Prot Src_Ports Dst_Ports CT_State Extra
  mk_L4Ports_pre
  ProtoAny Proto TCP UDP ICMP L4_Protocol.IPv6ICMP L4_Protocol.SCTP L4_Protocol.GRE
  L4_Protocol.ESP L4_Protocol.AH
  Iface
  integer_to_16word nat_to_16word nat_of_integer integer_of_nat word_less_eq word_to_nat 
  nat_to_8word
  IpAddrNetmask IpAddrRange IpAddr
  CT_New CT_Established CT_Related CT_Untracked CT_Invalid
  TCP_Flags TCP_SYN TCP_ACK TCP_FIN TCP_RST TCP_URG TCP_PSH
  Accept Drop Log Reject Call Return Goto Empty Unknown
  action_toString
  (*IPv4*)
  ipv4addr_of_dotdecimal
  ipt_ipv4range_toString
  common_primitive_ipv4_toString
  common_primitive_match_expr_ipv4_toString
  simple_rule_ipv4_toString
  (*IPv6*)
  mk_ipv6addr IPv6AddrPreferred ipv6preferred_to_int int_to_ipv6preferred
  ipt_ipv6range_toString
  common_primitive_ipv6_toString
  common_primitive_match_expr_ipv6_toString
  simple_rule_ipv6_toString
  (*Goto support*)
  Semantics_Goto.rewrite_Goto_safe
  (*parser helpers:*) alist_and' compress_parsed_extra fill_l4_protocol Pos Neg mk_Set
  unfold_ruleset_CHAIN_safe map_of_string
  upper_closure
  abstract_for_simple_firewall optimize_matches
  packet_assume_new
  to_simple_firewall
  to_simple_firewall_without_interfaces
  sanity_wf_ruleset
  has_default_policy
  (*spoofing:*) ipassmt_generic_ipv4 ipassmt_generic_ipv6
  no_spoofing_iface ipassmt_sanity_defined map_of_ipassmt to_ipassmt ipassmt_diff
  Pos Neg
  (*debug*)
  simple_fw_valid
  debug_ipassmt_ipv4 debug_ipassmt_ipv6
  (*ip partitioning*)
  access_matrix_pretty_ipv4 access_matrix_pretty_ipv6
  mk_parts_connection_TCP (*parts_connection_ssh parts_connection_http*)
  (* routing *)
  PrefixMatch routing_rule_ext routing_action_ext
  routing_action_oiface_update metric_update routing_action_next_hop_update empty_rr_hlp sort_rtbl
  prefix_match_32_toString routing_rule_32_toString prefix_match_128_toString routing_rule_128_toString
  default_prefix sanity_ip_route ipassmt_diff routing_ipassmt
  checking SML Haskell? (*in Haskell module_name "Network.IPTables.Generated" file "generated_code/"*)

end

Theory Access_Matrix_Embeddings

theory Access_Matrix_Embeddings
imports Semantics_Embeddings
        "Primitive_Matchers/No_Spoof"
        Simple_Firewall.Service_Matrix
begin

section‹Applying the Access Matrix to the Bigstep Semantics›
  
text‹
If the real iptables firewall (@{const iptables_bigstep}) accepts a packet, we have a corresponding
edge in the @{const access_matrix}.
›
corollary access_matrix_and_bigstep_semantics:
  defines "preprocess rs  upper_closure (optimize_matches abstract_for_simple_firewall (upper_closure (packet_assume_new rs)))"
  and     "newpkt p  match_tcp_flags ipt_tcp_syn (p_tcp_flags p)  p_tag_ctstate p = CT_New"
  fixes γ :: "'i::len common_primitive  ('i, 'pkt_ext) tagged_packet_scheme  bool"
  and   p :: "('i::len, 'pkt_ext) tagged_packet_scheme"
  assumes agree:"matcher_agree_on_exact_matches γ common_matcher"
  and     simple: "simple_ruleset rs"
  and     new: "newpkt p"             
  and     matrix: "(V,E) = access_matrix pc_iiface = p_iiface p, pc_oiface = p_oiface p, pc_proto = p_proto p, pc_sport = p_sport p, pc_dport = p_dport p (to_simple_firewall (preprocess rs))"
  and     accept: "Γ,γ,p rs, Undecided  Decision FinalAllow"
  shows "s_repr d_repr s_range d_range. (s_repr, d_repr)  set E 
              (map_of V) s_repr = Some s_range  (p_src p)  wordinterval_to_set s_range 
              (map_of V) d_repr = Some d_range  (p_dst p)  wordinterval_to_set d_range"
proof -
  let ?c=" pc_iiface = p_iiface p, c_oiface = p_oiface p, pc_proto = p_proto p,
           pc_sport = p_sport p, pc_dport = p_dport p "
  from new_packets_to_simple_firewall_overapproximation[OF agree simple] have
    "{p. Γ,γ,p rs, Undecided  Decision FinalAllow  newpkt p}
      
     {p. simple_fw (to_simple_firewall (preprocess rs)) p = Decision FinalAllow  newpkt p}"
    unfolding preprocess_def newpkt_def by blast
  with accept new have "simple_fw (to_simple_firewall (preprocess rs)) p = Decision FinalAllow" by blast
  hence "runFw_scheme (p_src p) (p_dst p) ?c p (to_simple_firewall (preprocess rs)) = Decision FinalAllow"
    by(simp add: runFw_scheme_def)
  hence "runFw (p_src p) (p_dst p) ?c (to_simple_firewall (preprocess rs)) = Decision FinalAllow"
    by(simp add: runFw_scheme[symmetric])
  with access_matrix[OF matrix] show ?thesis by presburger
qed

(*Actually, I want to_simple_firewall_without_interfaces so we don't depend on interfaces*)
corollary access_matrix_no_interfaces_and_bigstep_semantics:
  defines "newpkt p  match_tcp_flags ipt_tcp_syn (p_tcp_flags p)  p_tag_ctstate p = CT_New"
  fixes γ :: "'i::len common_primitive  ('i, 'pkt_ext) tagged_packet_scheme  bool"
  and   p :: "('i::len, 'pkt_ext) tagged_packet_scheme"
  assumes agree:"matcher_agree_on_exact_matches γ common_matcher"
  and     simple: "simple_ruleset rs"
      ― ‹To get the best results, we want to rewrite all interfaces, which needs some preconditions›
      (*TODO: actually, we use iface_try_rewrite which should work without assumptions but may give bad (but sound) results*)
      ― ‹well-formed ipassmt›
      and wf_ipassmt1: "ipassmt_sanity_nowildcards (map_of ipassmt)" and wf_ipassmt2: "distinct (map fst ipassmt)"
      ― ‹There are no spoofed packets (probably by kernel's reverse path filter or our checker).
         This assumption implies that ipassmt lists ALL interfaces (!!).›
      and nospoofing: "(p::('i::len, 'pkt_ext) tagged_packet_scheme).
            ips. (map_of ipassmt) (Iface (p_iiface p)) = Some ips  p_src p  ipcidr_union_set (set ips)"
      ― ‹If a routing table was passed, the output interface for any packet we consider is decided based on it.›
      and routing_decided: "rtbl (p::('i,'pkt_ext) tagged_packet_scheme). rtblo = Some rtbl  output_iface (routing_table_semantics rtbl (p_dst p)) = p_oiface p"
      ― ‹A passed routing table is wellformed›
      and correct_routing: "rtbl. rtblo = Some rtbl  correct_routing rtbl"
      ― ‹A passed routing table contains no interfaces with wildcard names›
      and routing_no_wildcards: "rtbl. rtblo = Some rtbl  ipassmt_sanity_nowildcards (map_of (routing_ipassmt rtbl))"
  and     new: "newpkt p"
  ― ‹building the matrix over ANY interfaces, not mentioned anywhere. That means, we don't care about interfaces!›
  and     matrix: "(V,E) = access_matrix pc_iiface = anyI, pc_oiface = anyO, pc_proto = p_proto p, pc_sport = p_sport p, pc_dport = p_dport p
                            (to_simple_firewall_without_interfaces ipassmt rtblo rs)"
  and     accept: "Γ,γ,p rs, Undecided  Decision FinalAllow"
  shows "s_repr d_repr s_range d_range. (s_repr, d_repr)  set E 
              (map_of V) s_repr = Some s_range  (p_src p)  wordinterval_to_set s_range 
              (map_of V) d_repr = Some d_range  (p_dst p)  wordinterval_to_set d_range"
proof -
  let ?c=" pc_iiface = p_iiface p, c_oiface = p_oiface p, pc_proto = p_proto p,
           pc_sport = p_sport p, pc_dport = p_dport p "
  let ?srs="to_simple_firewall_without_interfaces ipassmt rtblo rs"
  note tosfw=to_simple_firewall_without_interfaces[OF simple wf_ipassmt1 wf_ipassmt2 nospoofing routing_decided correct_routing routing_no_wildcards, of rtblo, simplified]
  from tosfw(2) have no_ifaces: "simple_firewall_without_interfaces ?srs" unfolding simple_firewall_without_interfaces_def by fastforce
  from simple simple_imp_good_ruleset have "good_ruleset rs" by blast
  with accept FinalAllow_approximating_in_doubt_allow[OF agree] have accept_ternary:
    "(common_matcher, in_doubt_allow),p rs, Undecided α Decision FinalAllow" by blast
  from tosfw(1) have
    "{p.(common_matcher, in_doubt_allow),p rs, Undecided α Decision FinalAllow  newpkt p}
      
     {p. simple_fw ?srs p = Decision FinalAllow  newpkt p}"
    unfolding newpkt_def by blast
  with accept_ternary new have "simple_fw ?srs p = Decision FinalAllow" by blast
  hence "runFw_scheme (p_src p) (p_dst p) ?c p ?srs = Decision FinalAllow"
    by(simp add: runFw_scheme_def)
  hence "runFw (p_src p) (p_dst p) ?c ?srs = Decision FinalAllow"
    by(simp add: runFw_scheme[symmetric])
  hence "runFw (p_src p) (p_dst p) 
          pc_iiface = anyI, pc_oiface = anyO, pc_proto = p_proto p, pc_sport = p_sport p, pc_dport = p_dport p ?srs = Decision FinalAllow"
    apply(subst runFw_no_interfaces[OF no_ifaces]) by simp
  with access_matrix[OF matrix] show ?thesis by presburger
qed
 
end

Theory Documentation

theory Documentation
imports Semantics_Embeddings
    Call_Return_Unfolding
    No_Spoof_Embeddings
    Access_Matrix_Embeddings
    "Primitive_Matchers/Code_Interface"
begin



section‹Documentation›

subsection‹General Model›
text‹
The semantics of the filtering behavior of iptables is expressed by @{const iptables_bigstep}.
The notation @{term "Γ,γ,p rs, s  t"} reads as follows:
  @{term "Γ :: string  'a rule list"} is the background ruleset (user-defined rules).
  @{term γ} is a function @{typ "('a, 'p) matcher"} which is called the primitive matcher (i.e. the matching features supported by iptables).
  @{term "p :: 'p"} is the packet inspected by the firewall.
  @{term "rs :: 'a rule list"} is the ruleset.
  @{term "s :: state"} and @{term "t :: state"} are the start state and final state.


The semantics:
\begin{center}
@{thm[mode=Axiom] skip [no_vars]}\\[1ex]
@{thm[mode=Rule] accept [no_vars]}\\[1ex]
@{thm[mode=Rule] drop [no_vars]}\\[1ex]
@{thm[mode=Rule] reject [no_vars]}\\[1ex]
@{thm[mode=Rule] log [no_vars]}\\[1ex]
@{thm[mode=Rule] empty [no_vars]}\\[1ex]
@{thm[mode=Rule] nomatch [no_vars]}\\[1ex]
@{thm[mode=Rule] decision [no_vars]}\\[1ex]
@{thm[mode=Rule] seq [no_vars]} \\[1ex]
@{thm[mode=Rule] call_return [no_vars]}\\[1ex] 
@{thm[mode=Rule] call_result [no_vars]}
\end{center}
›


subsection‹Unfolding the Ruleset›

text‹We can replace all @{const Goto}s to terminal chains (chains that ultimately yield a final
  decision for every packet) with @{const Call}s.
  Otherwise we don't have as rich goto semantics as iptables has, but this rewriting is safe.

@{thm Semantics_Goto.rewrite_Goto_chain_safe [no_vars]}

text‹The iptables firewall starts as follows:
  @{term "[Rule MatchAny (Call chain_name), Rule MatchAny default_action]"}
  We call to a built-in chain @{term chain_name}, usually INPUT, OUTPUT, or FORWARD.
  If we don't get a decision, iptables uses the default policy (-P) @{term default_action}.

  We can call @{const unfold_optimize_ruleset_CHAIN} to remove all calls to user-defined chains
  and other unpleasant actions. We get back a @{const simple_ruleset} which as exactly the same 
  behaviour. As a bonus, this @{const simple_ruleset} already has some match conditions optimized.

  For example, if the parser does not find a source IP in a rule, it is okay to specify
  -s 0.0.0.0/0, the unfolding will optimize away these things for you.
  Or if you parse iptables -L -n which always has these annoying 0.0.0.0/0 fields.
  May make the parser easier.
  The following lemma shows that this does not change the semantics.

›
lemma unfold_optimize_common_matcher_univ_ruleset_CHAIN:
    ― ‹for IPv4 and IPv6 packets›
    fixes γ :: "'i::len common_primitive  ('i, 'pkt_ext) tagged_packet_scheme  bool"
    and   p :: "('i::len, 'pkt_ext) tagged_packet_scheme"
    assumes "sanity_wf_ruleset Γ" and "chain_name  set (map fst Γ)"
    and "default_action = action.Accept  default_action = action.Drop"
    and "matcher_agree_on_exact_matches γ common_matcher"
    and "unfold_ruleset_CHAIN_safe chain_name default_action (map_of Γ) = Some rs"
    shows "(map_of Γ),γ,p rs, s  t 
           (map_of Γ),γ,p [Rule MatchAny (Call chain_name), Rule MatchAny default_action], s  t"
    and "simple_ruleset rs"
apply(intro unfold_optimize_ruleset_CHAIN[where optimize=optimize_primitive_univ, OF assms(1) assms(2) assms(3)])
  using assms apply(simp_all add: unfold_ruleset_CHAIN_safe_def Semantics_optimize_primitive_univ_common_matcher)
by(simp add: unfold_optimize_ruleset_CHAIN_def Let_def split: if_split_asm)


subsection‹Spoofing protection›

text‹We provide an executable algorithm @{const no_spoofing_iface} which checks that a ruleset provides spoofing protection:

@{thm no_spoofing_executable_set [no_vars]}

Text the firewall needs normalized match conditions, this is a good way to preprocess the firewall before 
checking spoofing protection:

@{thm no_spoofing_executable_set_preprocessed [no_vars]}

subsection‹Simple Firewall Model›
text‹The simple firewall supports the following match conditions: @{typ "'i::len simple_match"}.

The @{const simple_fw} model is remarkably simple: @{thm simple_fw.simps [no_vars]}

We support translating to a stricter version (a version that accepts less packets): 

@{thm new_packets_to_simple_firewall_underapproximation [no_vars]}


We support translating to a more permissive version (a version that accepts more packets): 

@{thm new_packets_to_simple_firewall_overapproximation [no_vars]}



There is also a different approach to translate to the simple firewall which removes all matches on interfaces:

@{thm to_simple_firewall_without_interfaces[no_vars]}


subsection‹Service Matrices›
text‹
For a @{typ "'i::len simple_rule list"} and a fixed @{typ parts_connection}, 
we support to partition the IPv4 address space the following.

All members of a partition have the same access rights:
@{thm build_ip_partition_same_fw [no_vars]}

Minimal:
@{thm build_ip_partition_same_fw_min [no_vars]}


The resulting access control matrix is sound and complete:

@{thm access_matrix [no_vars]}

Theorem reads: 
For a fixed connection, you can look up IP addresses (source and destination pairs) in the matrix 
if and only if the firewall accepts this src,dst IP address pair for the fixed connection.
Note: The matrix is actually a graph (nice visualization!), you need to look up IP addresses 
in the Vertices and check the access of the representants in the edges. If you want to visualize
the graph (e.g. with Graphviz or tkiz): The vertices are the node description (i.e. header; 
  @{term "dom V"} is the label for each node which will also be referenced in the edges,
  @{term "ran V"} is the human-readable description for each node (i.e. the full IP range it represents)), 
the edges are the edges. Result looks nice. Theorem also tells us that this visualization is correct.
›

text‹
A final theorem which does not mention the simple firewall at all.
If the real iptables firewall (@{const iptables_bigstep}) accepts a packet, we have a corresponding
edge in the @{const access_matrix}:

@{thm access_matrix_and_bigstep_semantics [no_vars]}


Actually, we want to ignore all interfaces for a service matrix.
This is done in @{thm access_matrix_no_interfaces_and_bigstep_semantics[no_vars]}.
The theorem reads a bit ugly because we need well-formedness assumptions if we rewrite interfaces.
Internally, it uses @{const iface_try_rewrite} which is pretty safe to use, even if you don't have
an @{term ipassmt} or routing tables.
›

end